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

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
  • tanayprasad's avatar
    tanayprasad
    Brass Contributor
    Jul 25, 2023

    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.

Resources