Speeding Up VBA execution

[waygar]

Hi,

The following code searches a large database for cells with a certain fill color and then removes the underlying conditional formatting. The runtime is quite slow. Can this code be made more efficient?

Thank you.

RGBCode = RGB(192, 0, 0) For Each Cell In Range("D:D") If Cell.Interior.Color <> RGBCode Then GoTo Label10 Cell.Select Selection.FormatConditions.Delete Label10: Next Cell

[#2]

@waygar 

Is this better?

Sub Test()
    Dim RGBCode As Long
    Dim Cell As Range
    Dim Rng As Range
    Dim Adr As String
    Application.ScreenUpdating = False
    RGBCode = RGB(192, 0, 0)
    With Application.FindFormat
        .Clear
        .Interior.Color = RGBCode
    End With
    Set Cell = Range("D:D").Find(What:="", LookAt:=xlPart, SearchFormat:=True)
    If Not Cell Is Nothing Then
        Adr = Cell.Address
        Do
            If Rng Is Nothing Then
                Set Rng = Cell
            Else
                Set Rng = Union(Cell, Rng)
            End If
            Set Cell = Range("D:D").Find(What:="", After:=Cell, LookAt:=xlPart, SearchFormat:=True)
            If Cell Is Nothing Then Exit Do
        Loop Until Cell.Address = Adr
        Rng.FormatConditions.Delete
    End If
    Application.ScreenUpdating = True
End Sub

[#3]

Thanks Hans,
The following section of code searches a sheet containing thousands of entries and places a "del" in the first column of a row satisfying certain conditions, marking that row for ultimately removing that row using say an autofilter deletion. The code is very slow when there are many rows of data. Is there a better more efficient means of implementing this sort of screening for eventual deletion?
Thank you.

Option Explicit
Sub Obsolete()
Dim l1Row As Long
Dim II As Long
Dim JJ As Long
Dim SBSO As String
SBSO = "SBS Online"

l1Row = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

For II = 2 To l1Row
For JJ = 3 To l1Row
If Range("D" & II) = Range("D" & JJ) And Range("C" & II) = Range("C" & JJ) Then GoTo Label10
GoTo Label100
Label10:
If Range("E" & II) <> SBSO And Range("E" & JJ) <> SBSO Then GoTo Label200
If Range("E" & II) = SBSO And Range("F" & II) > Range("F" & JJ) Then Range("A" & II) = "del"
If Range("E" & JJ) = SBSO And Range("F" & JJ) > Range("F" & II) Then Range("A" & JJ) = "del"
GoTo Label200
Label100:
Next JJ
Label200:
Next II
End Sub

[#4]

@waygar 

Try this. Please test it on a smaller subset first, to see if it works.

Sub Obsolete()
    Const SBSO = "SBS Online"
    Dim l1Row As Long
    Dim II As Long
    Dim JJ As Long
    Dim v As Variant

    Application.ScreenUpdating = False
    l1Row = Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    v = Range("A1:F" & l1Row).Value

    For II = 2 To l1Row - 1
        For JJ = II + 1 To l1Row
            If v(II, 4) = v(JJ, 4) And v(II, 3) = v(JJ, 3) Then
                If v(II, 5) <> SBSO And v(JJ, 5) <> SBSO Then Exit For
                If v(II, 5) = SBSO And v(II, 6) > v(JJ, 6) Then v(II, 1) = "del"
                If v(JJ, 5) = SBSO And v(JJ, 6) > v(II, 6) Then v(JJ, 1) = "del"
                Exit For
            End If
        Next JJ
    Next II

    Range("A1:F" & l1Row).Value = v
    Application.ScreenUpdating = True
End Sub

[#5]

Thanks Hans,
That is unbelievable. A test data set took 80 seconds to complete with my code whereas your routine did it in less than a second.
Unbelievable.
Cheers,

[#6]

@waygar

My version reads the data into an array, traverses the array and then writes the array back to the sheet in one go.

Array manipulations are much faster than sheet manipulations.

[#7]

Hi Hans,
Do you lose cell formatting in this approach when moving data in and out of arrays?

[#8]

@waygar 

All formatting should be preserved.

But formulas will be replaced with their result.

[#9]

Hi Hans,
How do I create a Userform that contains, among other things, a combo box that contains a list of dates with one date to select. The default date that is initially shown must be today's date and the dates that can be selected range from say 14 days before the default of today's date to 14 days ahead of today's date. Of course today's date will change eveyday. It would be preferable not to have this list in any worksheet if possible.

[#10]

@waygar 

Let's say you have a combo box DateCombo. In the userform's code module:

Private Sub UserForm_Initialize()
    Dim d As Date
    For d = Date - 14 To Date + 14
        Me.DateCombo.AddItem d
    Next d
    Me.DateCombo = Date
End Sub

[#11]

Thanks Hans,
It works nicely but the date format is eg 3/24/2023. How can I get the date format to be 24/03/2023? I have all regional settings correct but...
Cheers,
Wayne

[#12]

@waygar 

Use

        Me.DateCombo.AddItem Format(d, "dd/mm/yyyy")