# Optimizing a large report sorting macro

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

• 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. Oct 6, 2022 at 19:11
• Ps you may want to indent your code automatically to keep it consistent test.rubberduckvba.com/Indenter Oct 6, 2022 at 19:22
• Added a couple sample tables and how they work with each other. I'll definitely look at the auto indenter! Oct 6, 2022 at 19:41
• You should refactor this code to eliminate the goto's and the labels. Absolutely not needed in VBA. Oct 7, 2022 at 23:22

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.

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")
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
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
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
`
• 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 Oct 14, 2022 at 15:40