Optimizing a large report sorting macro

Question

I've been working on this project for my organization for a few months now, and am looking for ways to increase performance on this macro.

I work for an insurance company as a claims auditor. I get a report daily of claims that were ran the day before and look for abnormalities to audit. The below macro compares the drugs on the report to normal averages that are stored in a separate workbook.

In its current state, it runs through about 100 rows/second. For some of our larger reports, this can mean the macro runs for 10+ minutes, so I'm hoping for some feedback on how to optimize this so it works faster.

I've already changed from using the .Find method to looking through an Array which is definitely faster, but I'm sure there's more I could do to make this perform better. I've never taken any formal classes and have been learning on the go. Any help is appreciated.

Sample Report Data Workbook

Drug Name	Quantity	Day Supply	NDC
A	30	30	01234567890
B	45	30	01234567810
C	6.7	16	02345678122

Sample Averages Workbook

NDC	Average	Drug Name
01234567890	1	A
01234567810	1	B
02345678122	0.2233	C

Using these tables as examples, the macro takes D2 from the Report, finds it in the Averages workbook, and checks to see if the value of B2/C2 is greater than the average (With a 15% tolerance)

Sub TEST_DrugAverages()
 
 Application.ScreenUpdating = False
 
 'Define all variables
 Dim i As Long 'Row number of current report
 Dim numberOfRows As Long 'Total number of rows in the report
 Dim ndcNum As String 'Current NDC Number
 Dim drugQuantity As Double 'Current drug quantity
 Dim drugDaySupply As Integer 'Current drug day supply
 Dim drugRatio As Double 'Drug Quantity divided by Drug Day Supply
 Dim AverageArray() As Variant 'Array where master averages are stored
 Dim wb As Workbook 'Workbook where master averages are stored
 Dim ws1 As Worksheet 'Worksheet where master averages are stored
 Dim ndcRng, qtyRng, dsRng As Range 'User selected columns of where each attribute is
 Dim masterAverage As Double
 
 
 'Set Workbook and Worksheet where master averages are stored
 Set wb = Application.Workbooks("TESTDrugAverages.xlsb")
 Set ws1 = wb.Worksheets("Master")
 
 AverageArray = ws1.Range("A1:A4") 'Set Array using data in another workbook. 4 rows for code review
 
 numberOfRows = Cells.Find(What:="*", SearchDirection:=xlPrevious).Row 'Set the total number of rows in the report
 
 'Column numbers. Static numbers for code review, normally user defined
 Set ndcRng = 4
 Set qtyRng = 2
 Set dsRng = 3
 
 'Start sorting
Start:
 For i = 1 To numberOfRows 'For all rows in the report, down to the number of rows we found at the beginning
 ndcNum = Cells(i, ndcRng).Value 'Finds the row's current drug NDC
 If ndcNum = "" Then GoTo DoNothing Else GoTo Check2 'Checks if a anything is present in the Drug Name column
 
Check2: 'If it is the column header (found by text equals), then skip the row. Will change this to an array in the future to be more flexible
 If ndcNum Like "Drug *" Or ndcNum Like "NDC *" Or ndcNum Like "DRUG" Or ndcNum Like "0" Then GoTo DoNothing Else GoTo RunMacro
 
RunMacro: 'Drug NDC identified, this is the meat
 drugQuantity = Cells(i, qtyRng)
 drugDaySupply = Cells(i, dsRng)
 drugRatio = drugQuantity / drugDaySupply
 
 
 masterAverage = 0 'Resets masterAverage to 0 indicate Compund Drug which will be skipped
 
 
 Dim j As Long
 
 For j = LBound(AverageArray, 1) To UBound(AverageArray, 1) 'Searches Array for current NDC. Sets masterAverage once found
 If AverageArray(j, 1) = ndcNum Then
 masterAverage = ws1.Cells(j, 2).Value
 'Debug.Print ws1.Cells(j, 2).Value & " " & ndcAverage
 End If
 Next j
 
 
 If masterAverage = 0 Then
 Debug.Print i & " Cannot find NDC"
 Cells(i, ndcRng.Column).EntireRow.Interior.ColorIndex = 38
 GoTo DoNothing
 Else
 
 If (drugRatio * 0.85) > masterAverage Then
 'Debug.Print drugRatio; ">"; masterAverage
 Debug.Print i & " Audit this claim"
 Cells(i, ndcRng.Column).EntireRow.Interior.ColorIndex = 37
 Else
 Debug.Print i & " No need to audit"
 Cells(i, ndcRng.Column).EntireRow.Interior.ColorIndex = 35
 End If
 
 'For visual debugging on the report
 Cells(i, "W").Value = drugRatio
 Cells(i, "X").Value = masterAverage
 
 End If
 
DoNothing:
 
 Next i
 
 
Application.ScreenUpdating = True
 
MsgBox "Your report has been formatted!" & Chr(13) & Chr(10) & "Blue = Potential audits" & Chr(13) & Chr(10) & "Red = Drugs not included on the Master List" & Chr(13) & Chr(10) & "Green = Within drug average, no need to audit"
 
End Sub

• Greedo: Sample data? Doesn't have to be real data, E.g. table headers & data types, worksheet and workbook layout. You can enter tables in markdown Good question & context though.
• Greedo: Ps you may want to indent your code automatically to keep it consistent test.rubberduckvba.com/Indenter
• Dallin DeFord: Added a couple sample tables and how they work with each other. I'll definitely look at the auto indenter!
• Freeflow: You should refactor this code to eliminate the goto's and the labels. Absolutely not needed in VBA.

Answer 1

Collections and Scripting Dictionaries are optimized for ID matching and are much faster then iterating over an array.

Adding a helper column is not only faster but more useful. Instead of visually inspecting each row, the user can filter column. You could also use formulas to count the number of missing IDs, passes and fails.

Download Workbook

The test worksheet I used had 60K rows of data.

The AddHelperColumn() subroutine adds the helper column in 0.36 Seconds. Conditional formatting rules could use the helper column to format the worksheet.

My optimized version of the OP's formatting code, `FormatReport(), takes about 2.56 seconds to format the worksheet.

Test

Sub TEST_HelperColumn()
 Const NDCColumn As Long = 4
 Const SupplyColumn As Long = 3
 Const QuantityColumn As Long = 2
 
 Dim Averages As Collection
 Set Averages = NDCAverages
 
 Dim Target As Range
 Set Target = Range("A1").CurrentRegion
 
 Dim t As Double
 t = Timer
 AddHelperColumn Target, Averages, NDCColumn, SupplyColumn, QuantityColumn
 
 Dim RunTime As Double
 RunTime = Round((Timer - t), 4)
 
 Debug.Print "TEST_DrugAverages ran in "; RunTime; " second(s)"
 
 Dim Passed As Long, Failed As Long, NoMatch As Long
 
 With Target
 With .Offset(0, .Columns.Count).Resize(, 1)
 Passed = WorksheetFunction.CountIf(.Cells, "Pass")
 Failed = WorksheetFunction.CountIf(.Cells, "=Fail")
 NoMatch = WorksheetFunction.CountIf(.Cells, "=NDC Not Found")
 End With
 End With
 
 MsgBox "Audit Column Added" & vbNewLine & _
 Passed & " Passed" & vbNewLine & _
 Failed & " Failed" & vbNewLine & _
 NoMatch & " No NDC Found"
 
End Sub
Sub TEST_FormatRows()
 Const NDCColumn As Long = 4
 Const SupplyColumn As Long = 3
 Const QuantityColumn As Long = 2
 
 Dim Averages As Collection
 Set Averages = NDCAverages
 
 Dim Target As Range
 Set Target = Range("A1").CurrentRegion
 Target.EntireRow.ClearFormats
 
 
 Dim t As Double
 t = Timer
 FormatReport Target, Averages, NDCColumn, SupplyColumn, QuantityColumn
 Dim RunTime As Double
 RunTime = Round((Timer - t), 4)
 
 Debug.Print "TEST_DrugAverages ran in "; RunTime; " second(s)"
 
 Dim Passed As Long, Failed As Long, NoMatch As Long
 
 MsgBox "Your report has been formatted!" & vbNewLine & "Blue = Potential audits" & vbNewLine & "Red = Drugs not included on the Master List" & vbNewLine & "Green = Within drug average, no need to audit"
End Sub
Sub AddHelperColumn(Target As Range, Averages As Collection, NDCColumn As Long, SupplyColumn As Long, QuantityColumn As Long)
 
 Dim Key As String
 Dim Data As Variant
 Data = Target.Value
 
 Dim DrugQuantity As Double 'Current drug quantity
 Dim DrugDaySupply As Integer 'Current drug day supply
 Dim DrugRatio As Double 'Drug Quantity divided by Drug Day Supply
 Dim Average As Double
 
 Dim Categories As Variant
 ReDim Categories(1 To Target.Rows.Count, 1 To 1)
 Categories(1, 1) = "Audit"
 
 Dim r As Long
 For r = 2 To UBound(Data)
 Key = Data(r, NDCColumn)
 DrugQuantity = Data(r, QuantityColumn)
 DrugDaySupply = Data(r, SupplyColumn)
 If DrugDaySupply > 0 Then
 DrugRatio = DrugQuantity / DrugDaySupply
 Else
 DrugRatio = 0
 End If
 
 
 If KeyExists(Key, Averages) Then
 Average = Averages(Key)
 If (DrugRatio * 0.85) > Average Then
 Categories(r, 1) = "Fail"
 Else
 Categories(r, 1) = "Pass"
 End If
 Else
 Categories(r, 1) = "NDC Not Found"
 End If
 Next
 
 Dim ScreenUpdating As Boolean
 
 ScreenUpdating = Application.ScreenUpdating
 Application.ScreenUpdating = False
 
 With Target
 .Offset(0, .Columns.Count).Resize(, 1).Value = Categories
 End With
 
 Application.ScreenUpdating = ScreenUpdating
 
End Sub
 
Sub FormatReport(Target As Range, Averages As Collection, NDCColumn As Long, SupplyColumn As Long, QuantityColumn As Long)
 Dim ScreenUpdating As Boolean
 
 ScreenUpdating = Application.ScreenUpdating
 Application.ScreenUpdating = False
 Dim Key As String
 Dim Data As Variant
 Data = Target.Value
 
 Dim DrugQuantity As Double 'Current drug quantity
 Dim DrugDaySupply As Integer 'Current drug day supply
 Dim DrugRatio As Double 'Drug Quantity divided by Drug Day Supply
 Dim Average As Double
 Dim CurrentRow As Range
 
 Dim r As Long
 For r = 2 To UBound(Data)
 Key = Data(r, NDCColumn)
 DrugQuantity = Data(r, QuantityColumn)
 DrugDaySupply = Data(r, SupplyColumn)
 If DrugDaySupply > 0 Then
 DrugRatio = DrugQuantity / DrugDaySupply
 Else
 DrugRatio = 0
 End If
 
 Set CurrentRow = Target.Rows(r)
 
 If KeyExists(Key, Averages) Then
 Average = Averages(Key)
 If (DrugRatio * 0.85) > Average Then
 'EasyUnion InvalidRows, CurrentRow
 CurrentRow.EntireRow.Interior.ColorIndex = 37
 Else
 'EasyUnion ValidRows, CurrentRow
 CurrentRow.EntireRow.Interior.ColorIndex = 35
 End If
 Else
 'EasyUnion NoNDCRows, CurrentRow
 CurrentRow.EntireRow.Interior.ColorIndex = 38
 End If
 Next
 
 Application.ScreenUpdating = ScreenUpdating
End Sub
 
Function NDCAverages() As Collection
 Dim Collection As New Collection
 Dim Data As Variant
 Dim Key As String
 Dim Value As Double
 
 Data = wsDrugAverages.Range("A1").CurrentRegion
 
 Dim r As Long
 
 For r = 2 To UBound(Data)
 Key = Data(r, 1)
 Value = Val(Data(r, 2))
 
 If KeyExists(Key, Collection) Then
 Debug.Print "Duplicate NDC in Master Averages", Key
 Else
 Collection.Add Value, Key
 End If
 Next
 Set NDCAverages = Collection
End Function
 
Function wbDrugAverages() As Workbook
 Set wbDrugAverages = Application.Workbooks("TESTDrugAverages.xlsb")
End Function
 
Function wsDrugAverages() As Worksheet
 Set wsDrugAverages = wbDrugAverages.Worksheets("Master")
End Function
 
Public Function KeyExists(ByVal Key As String, ByRef Collection As Collection) As Boolean
 On Error Resume Next
 Dim temp As Variant
 temp = Collection.Item(Key)
 KeyExists = Err.Number = 0
 On Error GoTo 0
End Function

• TinMan: I didn't like the way I worded it either. I changed it to Collections and Scripting Dictionaries are optimized for ID matching and are much faster then iterating over an array.. Thanks @greybeard