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")

[#13]

Hi Hans,
Longtime no see.
Can I ask you a quick question regarding the fastest possible way to do what the code snippit below does. NRows1 can be very large, even as large or greater than 100000. This rearrangement needs to be done several times at different positions in the overall code of a very large macro. Is there a better and faster way?
Thanks.
Range("J9:J" & NRows1).Insert Shift:=xlToRight
Range("I9:I" & NRows1).Insert Shift:=xlToRight
Range("F9:F" & NRows1).Copy Destination:=Range("K9:K" & NRows1)
Range("E9:E" & NRows1).Copy Destination:=Range("I9:I" & NRows1)
Range("F9:F" & NRows1).Delete
Range("E9:E" & NRows1).Delete

[#14]

@waygar 

You can use the Find method to search for cells with the specific fill color, which can significantly improve the speed.

Sub RemoveConditionalFormattingByColor()
    Dim RGBCode As Long
    Dim FoundCell As Range
    Dim FirstAddress As String

    RGBCode = RGB(192, 0, 0)
    
    ' Search for the first cell with the specified fill color
    Set FoundCell = Columns("D:D").Find(What:=RGBCode, LookIn:=xlFormulas, LookAt:=xlWhole, SearchFormat:=True)
    
    ' If a cell with the specified fill color is found, start the loop
    If Not FoundCell Is Nothing Then
        FirstAddress = FoundCell.Address
        Do
            ' Remove the conditional formatting for the current cell
            FoundCell.FormatConditions.Delete
            
            ' Find the next cell with the specified fill color
            Set FoundCell = Columns("D:D").FindNext(FoundCell)
            
        ' Continue the loop until all cells with the specified fill color are found
        Loop While Not FoundCell Is Nothing And FoundCell.Address <> FirstAddress
    End If
End Sub

Try using this code once.

Best Regards.

[#15]

@waygar 

Hi Wayne, that depends on what the rest of the macro does.

If possible, the fastest way to do this would be to read the entire range into an array (that is just one instruction), manipulate that array, then writing the array back to the sheet (also one instruction).

Array manipulations are blindingly fast compared to cell manipulations.

[#16]

Thanks Hans,
Firstly my testing using the code below does not seem to speed up the original code unless you have a better approach and secondly all the formatting associated with array processing is lost unfortunately so another technique rather than array processing would be necessary?
Your thought?
Cheers,
Wayne
Sub Switch()
Dim v3 As Variant
Dim NRows3 As Long
Dim I As Long
NRows3 = 25330
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range("J6:J" & NRows3).Insert Shift:=xlToRight
Range("I6:I" & NRows3).Insert Shift:=xlToRight
v3 = Range("A7", "Q" & NRows3)

For I = 1 To NRows3 - 6
v3(I, 11) = v3(I, 6)
v3(I, 9) = v3(I, 5)
Next I

'Range("F6:F" & NRows3).Copy Destination:=wshCOMPL.Range("K6:K" & NRows3)
'Range("E6:E" & NRows3).Copy Destination:=wshCOMPL.Range("I6:I" & NRows3)

Range("F6:F" & NRows3).Delete
Range("E6:E" & NRows3).Delete
Range("A7", "Q" & NRows3) = v3
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

[#17]

A better and corrected version of the above is below and no faster"
Sub Switch()
Dim v5, v6, v9, v11 As Variant
Dim NRows3 As Long
Dim I As Long
NRows3 = 25330
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Range("J6:J" & NRows3).Insert Shift:=xlToRight
Range("I6:I" & NRows3).Insert Shift:=xlToRight

v5 = Range("E6:E" & NRows3)
v6 = Range("F6:F" & NRows3)
v9 = Range("I6:I" & NRows3)
v11 = Range("K6:K" & NRows3)

v11 = v6
v9 = v5

Range("E6:E" & NRows3) = v5
Range("F6:F" & NRows3) = v6
Range("I6:I" & NRows3) = v9
Range("K6:K" & NRows3) = v11

'Range("F6:F" & NRows3).Copy Destination:=Range("K6:K" & NRows3)
'Range("E6:E" & NRows3).Copy Destination:=Range("I6:I" & NRows3)

Range("F6:F" & NRows3).Delete
Range("E6:E" & NRows3).Delete

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

[#18]

@waygar 

So the code applies to a single row only? Is that correct?

[#19]

No to NRows3 rows which in the example is set to 25330

[#20]

@waygar 

Yes, but that is a single number - the code applies to row 25330, not to any other rows.

Or am I mistaken?

Sorry, I didn't look closely enough.

Stay tuned.