Most efficient way to highlight cells using VBA

[Huhenyo]

Hello everyone. I've got some very large sets of data that I have a VBA program highlighting, but it can take upwards of 25 minutes to complete on some data sets. I'm wondering if there is maybe a more efficient way to do this to help cut down the time it takes to process. Here is just a little piece of the code demonstrating the way I'm doing the highlighting. Your expertise is much appreciated. I love this forum!

For Each Cell In rngLookForNames
        strContents = Trim(Cell.Value)
        If strContents Like "?*)" And Not strContents Like "Patient(Chart*" Then ' starts with a letter and ends with ) but isn't "Patient(Chart#)
            lngRowNum = Cell.Row
            intTotalCount = intTotalCount + 1
            intAtLeastOneUpper = 0
            For k = 3 To lngNumberOfColumns
                If intUpperLimit <> 0 Then ' this indicates the person wanted an upperlimit
                    If Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Value >= intThreshold And Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Value < intUpperLimit Then
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .ThemeColor = xlThemeColorLight2
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Font
                            .ThemeColor = xlThemeColorDark1
                            .TintAndShade = 0
                        End With
                    End If                    If Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Value >= intUpperLimit Then
                        intAtLeastOneUpper = intAtLeastOneUpper + 1 ' if this is >0 then there was a value for the patient we are on that was > UpperLimit
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Borders(xlEdgeLeft)
                            .LineStyle = xlContinuous
                            .Color = 597641
                            .TintAndShade = 0
                            .Weight = xlThick
                        End With
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Borders(xlEdgeTop)
                            .LineStyle = xlContinuous
                            .Color = 597641
                            .TintAndShade = 0
                            .Weight = xlThick
                        End With
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Borders(xlEdgeBottom)
                            .LineStyle = xlContinuous
                            .Color = 597641
                            .TintAndShade = 0
                            .Weight = xlThick
                        End With
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Borders(xlEdgeRight)
                            .LineStyle = xlContinuous
                            .Color = 597641
                            .TintAndShade = 0
                            .Weight = xlThick
                        End With
                    End If
                Else ' if the person didn't want an uppper limit, just highlight everything above threshold
                    If Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Value >= intThreshold Then
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Interior
                            .Pattern = xlSolid
                            .PatternColorIndex = xlAutomatic
                            .ThemeColor = xlThemeColorLight2
                            .TintAndShade = 0
                            .PatternTintAndShade = 0
                        End With
                        With Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).Font
                            .ThemeColor = xlThemeColorDark1
                            .TintAndShade = 0
                        End With
                    End If
                End If
            Next
            If intAtLeastOneUpper > 0 Then
                intUpperCount = intUpperCount + 1 ' If there was at least one day > upperlimit, count that patient as one above upper limit
                 put a Red box around the person's name indicating that they are above the upper limit
                With Range(Cells(lngRowNum, 1), Cells(lngRowNum, 2)).Borders(xlEdgeLeft)
                    .LineStyle = xlContinuous
                    .Color = 597641
                    .TintAndShade = 0
                    .Weight = xlThick
                End With
                With Range(Cells(lngRowNum, 1), Cells(lngRowNum, 2)).Borders(xlEdgeTop)
                    .LineStyle = xlContinuous
                    .Color = 597641
                    .TintAndShade = 0
                    .Weight = xlThick
                End With
                With Range(Cells(lngRowNum, 1), Cells(lngRowNum, 2)).Borders(xlEdgeBottom)
                    .LineStyle = xlContinuous
                    .Color = 597641
                    .TintAndShade = 0
                    .Weight = xlThick
                End With
                With Range(Cells(lngRowNum, 1), Cells(lngRowNum, 2)).Borders(xlEdgeRight)
                    .LineStyle = xlContinuous
                    .Color = 597641
                    .TintAndShade = 0
                    .Weight = xlThick
                End With
            End If
        End If
        percentDone = Round(ticker / lngNumberOfRows, 2)
        If percentDone <> oldPercentDone Then
            frmCalculationsProgress3.CalculationsProgress (percentDone)
            oldPercentDone = percentDone
        End If
        ticker = ticker + 1
    Next Cell

 

[Huhenyo]

Fazza, I quickly changed over to using the BoarderAround method and that works just great. I'll have to take the time later to figure out how to create the text file (or string array) with all the ranges that need to be changed as you suggested. I think that will be the best method (kind of like holding control and clicking all the cells and then making the change once).

Just for future readers of this thread, using the BoarderAround method is more than 4 times faster than the way I previously did it (one step instead of 4). However, color and colorindex are not the same thing. You will need to get your color from the colorindex palette that can be found here: Color Palette and the 56 Excel ColorIndex Colors (second column).

 

[Fazza]

consider

Sub one()
  
  Dim i As Long
  Dim rngManyTogether As Excel.Range
  
  'Starting range
  Set rngManyTogether = Range("B4")
  
  For i = 1 To 100
    Set rngManyTogether = Union(rngManyTogether, Range("" & Chr(20 * Rnd() + 65) & Int(Rnd() * 15 + 1) & ""))
  Next i
  
  rngManyTogether.Interior.ColorIndex = 4

End Sub

Sub two()
  
  Dim i As Long
  Dim rngManyTogether As Excel.Range
  Dim asAddresses As Variant
  
  ReDim asAddresses(1 To 100)
  
  'Populate some addresses to an array
  For i = 1 To 100
    asAddresses(i) = "" & Chr(20 * Rnd() + 65) & Int(Rnd() * 15 + 1) & ""
  Next i
  
  'Initialise
  Set rngManyTogether = Range(asAddresses(1))
  
  For i = 2 To 100
    Set rngManyTogether = Union(rngManyTogether, Range(asAddresses(i)))
  Next i
  
  rngManyTogether.Interior.ColorIndex = 3

End Sub