Is there in VBA faster way to change row (or cell) color based on values without referring to cell Referring to cell each time inside loop is very slow, that's why i am looking for faster method doing it in VBA. Table:

If Amount1 is greater than Amount2, entire row(or cell) is red, vice versa entire row(or cell) is green.

Thank You!

CodePudding user response：

Highlight Rows

Sub HighlightRows()
    
Dim t As Double: t = Timer
    
    ' Define constants (adjust).
    
    Const PROC_TITLE As String = "Highlight Rows"
    Const SMALL_COL As Long = 1
    Const GREAT_COL As Long = 2
    
    Dim RowColors(): RowColors = VBA.Array(vbGreen, vbRed)
    
    ' Reference the table range.
    
    ' Turn off screen updating.
    Application.ScreenUpdating = False
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    If ws.FilterMode Then ws.ShowAllData ' clear any filters
    
    Dim trg As Range: Set trg = ws.Range("A1").CurrentRegion
    
    ' Validate rows and columns.
    
    ' Validate rows.
    Dim rCount As Long: rCount = trg.Rows.Count
    If rCount < 2 Then
        MsgBox "No data or just headers in the range '" _
            & trg.Address(0, 0) & "'.", vbCritical, PROC_TITLE
        Exit Sub ' screen updating will automatically get turned on
    End If
    
    ' Validate columns.
    Dim cCount As Long: cCount = trg.Columns.Count
    Dim MaxCol As Long: MaxCol = Application.Max(SMALL_COL, GREAT_COL)
    If cCount < GREAT_COL Then
        MsgBox "Column " & MaxCol & " is greater than the number " _
            & "of columns (" & cCount & ") in the range ('" _
            & trg.Address(0, 0) & "').", vbCritical, PROC_TITLE
        Exit Sub ' screen updating will automatically get turned on
    End If
    
    ' Reference and populate the helper columns.
    
    ' Insert two helper columns adjacent to the right of the table range.
    trg.Offset(, cCount).Resize(, 2).Insert xlShiftToRight
    ' Remove this line if there is no data to the right.
    
    ' Reference the expanded table range (including the helper columns)...
    Dim erg As Range: Set erg = trg.Resize(, cCount   2) ' has headers
    ' ... and reference its data to be used with 'SpecialCells'.
    Dim edrg As Range: Set edrg = erg.Resize(rCount - 1).Offset(1) ' no headers
    
    ' Reference the helper columns.
    Dim CompareCol As Long: CompareCol = cCount   1 ' for the auto filter
    Dim crg As Range: Set crg = erg.Columns(CompareCol)
    Dim irg As Range: Set irg = erg.Columns(cCount   2)
    
    ' Write an ascending integer sequence to the Integer column.
    irg.Value = ws.Evaluate("ROW(1:" & rCount & ")")
    
    ' Write the values from the criteria columns to arrays.
    Dim SmallData(): SmallData = erg.Columns(SMALL_COL).Value
    Dim GreatData(): GreatData = erg.Columns(GREAT_COL).Value
    
    ' Define the Compare array.
    Dim CompareData(): ReDim CompareData(1 To rCount, 1 To 1)
    
    Dim SmallVal, GreatVal, r As Long
    
    ' Write the Compare results to the Compare array
    ' (1 for the 1st color and 2 for the 2nd), ...
    For r = 2 To rCount ' skip headers
        SmallVal = SmallData(r, 1)
        GreatVal = GreatData(r, 1)
        If IsNumeric(SmallVal) And IsNumeric(GreatVal) Then
            Select Case SmallVal
                Case Is < GreatVal: CompareData(r, 1) = 1
                Case Is > GreatVal: CompareData(r, 1) = 2
            End Select
        End If
    Next r
    
    Erase SmallData
    Erase GreatData
    
    ' ... write the results from the array to the Compare column...
    crg.Value = CompareData
    Erase CompareData
    
    ' ... and sort the range by it.
    erg.Sort crg, xlAscending, , , , , , xlYes
    
    ' Highlight the rows.
    
    edrg.Interior.Color = xlNone ' clear previous colors
    
    Dim vedrg As Range
    
    For r = 1 To 2
        erg.AutoFilter CompareCol, CStr(r)
        On Error Resume Next ' prevent error when no filtered rows
            Set vedrg = edrg.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        ws.AutoFilterMode = False ' turn off the auto filter!!!
        If Not vedrg Is Nothing Then
            Debug.Print vedrg.Address ' only two areas are being highlighted
            vedrg.Interior.Color = RowColors(r - 1) ' 'RowColors' is zero-based
            Set vedrg = Nothing ' reset for the next iteration
        End If
    Next r
    
    ' Clean up.
    
    ' Sort the range by the Integer column restoring initial order.
    erg.Sort irg, xlAscending, , , , , , xlYes
    
    ' Delete the helper columns.
    crg.Resize(, 2).Delete xlShiftToLeft
    ' If you have removed the Insert-line, replace this line with:
    'crg.Resize(, 2).Clear
    
    ' Turn on screen updating to immediately see the changes
    ' (if the worksheet is active) before OK-ing the message box.
    Application.ScreenUpdating = True
    
Debug.Print Format(Timer - t, "00.000000")
    
    ' Inform.

    MsgBox "Rows highlighted.", vbInformation, PROC_TITLE
    
End Sub

CodePudding user response：

It would have been helpful if you had clarified why you can't use CF as suggested, but if you really can't when looping it's best to refer to directly to cells as little as possible, especially changing values or formats. Try something like this:

Sub SampleValues()
Dim bGreater As Boolean
Dim rng As Range, rRow As Range

    Set rng = ActiveSheet.Range("A1:B1000")
    rng.Formula = "=RANDBETWEEN(1,1000)"
    rng.Value = rng.Value

End Sub

Sub RedOrGreen()
Dim clr As Long, i as long
Dim rng As Range, rRow As Range
Dim arr As Variant
Const clrMore = vbGreen, clrLessEqual = vbRed

Dim t As Single
t = Timer

    Set rng = Range("A1:B1000")
    arr = rng.Value

    For Each rRow In rng.Rows
        i = i   1
        If arr(i, 2) > arr(i, 1) Then
            clr = clrMore
        Else
            clr = clrLessEqual
        End If

        If rRow.Interior.Color <> clr Then
            rRow.Interior.Color = clr
        End If
    Next

Debug.Print Timer - t
End Sub