For Each Next loop through range slowing down dramatically as iterations increase

[Huhenyo]

Hi everyone,

I have a for-each-next loop that loops through a range looking for people's names. Once it finds a name, it then looks though all the columns to the right of it within the row and highlights where the numbers are >= the threshold and upperlimit. The first couple hundred rows go really fast, but then it really starts to slow down. I have screen updating off and calculations are set to manual. The range that is being highlighted is a pivot table for what it's worth. Is there a way to delete the part of the range I'm done with as I loop through? I tried to use cell.delete, but it tries to delete the pivot table row and can't. The form that shows the progress is not the reason it is slowing down. It has something to do with the highlighting and how it uses ram and the processor. Any ideas on how to speed this up would be much appreciated. Oh, I've also tried to highlight groups of cells at a time, but that didn't improve things much.

Thank you.

Sub HighlightOpiodsAboveThreshold(ByVal intThreshold As Integer, ByVal intUpperLimit As Integer, ByVal bFastMode As Boolean)
    ActiveWorkbook.Worksheets("TDMME by Patient").Activate
    Dim rngLookForNames As Range, lngNumberOfRows As Long, Cell As Range, strContents As String, lngNumberOfColumns As Long
    Dim lngRowNum As Long, percentDone As Double, oldPercentDone As Double, ticker As Integer
    Dim intUpperCount As Integer, intTotalCount As Integer, intAtLeastOneUpper As Integer ' to get counts for those above threshold and upper limit
    lngNumberOfRows = ActiveSheet.UsedRange.Rows.Count + ActiveSheet.UsedRange.Rows(1).Row - 1 + 5 ' Because of the macro buttons at the top, the "used range" doesn't start until row 5
    lngNumberOfColumns = ActiveSheet.UsedRange.Columns.Count
    intThreshold = CInt(varThreshold)
    intUpperLimit = CInt(varUpperLimit)
    frmCalculationsProgress3.Show False
    Set rngLookForNames = Range(Cells(1, 1), Cells(lngNumberOfRows, 1))
    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
                        If bFastMode = False Then ' if bFastMode is true we will not do any highlighting
                            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 bFastMode = False Then
                    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
                        If bFastMode = False Then ' if bFastMode is true we will not do any highlighting
                            Range(Cells(lngRowNum, k), Cells(lngRowNum, k)).BorderAround ColorIndex:=9, Weight:=xlThick
                        End If ' If bFastMode = False Then
                    End If
                
                Else ' if the person didn't want an uppper limit, just highlight everything above threshold
                    If bFastMode = False Then ' if bFastMode is true we will not do any highlighting
                        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 ' If bFastMode = False Then
                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
                If bFastMode = False Then ' if bFastMode is true we will not do any highlighting
                    Range(Cells(lngRowNum, 1), Cells(lngRowNum, 2)).BorderAround ColorIndex:=9, Weight:=xlThick
                End If ' If bFastMode = False Then
            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

 

[James006]

Hello,

The first thing to do is to insert ... at the top of your macro

Application.Calculation = xlCalculationManual

and at the very end

Application.Calculation = xlCalculationAutomatic

HTH

 

[mole999]

can you do the formatting after working through, things like screenupdating false and calculation manual can help proving you are not relying on results for the next look.

do you underlying volitile formulas on the sheet ?

 

[Huhenyo]

Thank you for your posts. As mentioned in my original post, I have screen updating turned of (higher up in the code) and calculations set to manual (also higher up in the code). Mole999, I'm not sure what you are asking when you said, "do you underlying volitile formulas on the sheet?" - Do I have underlying volatile formulas on the sheet? No I don't. It is just a pivot table. I do have a couple macro linked buttons, however. Could that cause problems?

 

[Huhenyo]

What I ended up doing is changing all the highlighting to use the .BorderAround method which keeps me from needing to change fonts. This significantly sped things up. Thank you everyone for your help.

 

[Huhenyo]

What actually helped even more and allowed me to keep my cells highlighted was changing this:

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

to this:

With Range(Cells(lngRowNum, k), Cells(lngRowNum, k))
    .Interior.Color = RGB(68,84,106)
    .Font.Color = (255,255,255)
End With

In fact making that change made it more than twice as fast. It was even faster if I changed the color I wanted slightly so I didn't need to change the font color. The easiest way I found to get the RGB value is to just click on the cell, then on the fill buck dropdown, then on more colors, then on custom. I hope this helps someone. The other thing I will point out for anyone who may be having similar issues is that the .boaderaround is significantly faster than the first way I did the highlighting, but roughly the same as the second way.

-Huhenyo

 

[mole999]

although excel can use many colours, the original only allowed 56, and i've always had issues with tint shade, never thought it would be related to speed though, glad you have some improvement