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.
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.
Code:
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