Forum Discussion

waygar's avatar
waygar
Brass Contributor
Feb 15, 2023

Speeding Up VBA execution

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 eff...
Macros and VBA
HansVogelaar's avatar
HansVogelaar
MVP
Feb 15, 2023

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
  • waygar's avatar
    waygar
    Brass Contributor
    Mar 05, 2023
    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
    • HansVogelaar's avatar
      HansVogelaar
      MVP
      Mar 05, 2023

      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
      • waygar's avatar
        waygar
        Brass Contributor
        Mar 05, 2023
        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,

Share