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