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

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