Is there a generic benchmarking code that can be used to pin down performance hogs in your excel/vba code?

Question

There are some good posts that describe the two major ways of measuring the performance of your code. However, if you have a multi-module project with calls that may execute thousands of sub routine calls at a single operation, it is difficult to pin down where the performance hogs are. How to come about this?

Answer 1

I did write a generic benchmarking code that can be added to any vba project. It works by adding code to each entry and exit point of every sub/function/property to measure the time spent in each sub both as total time as well as time excluding sub-subroutines. This is how to use it:

1. Create a new module in your project called modBench. Naming is important.
2. Copy the code shown below to that module.
3. Make sure that Microsoft Visual Basic for Application Extensability is referenced in VBA
4. Make sure that you allow excel to allow "Trust access to the VBA project object model" (excel setting in Options=>Trust Center=>Trust Center Settings=>Macro Settings
5. Your workbook should be saved as a different name
6. Run "Start_Benchmark"
7. Do some tasks. Avoid msg-boxes and similar to show real "cpu-hogs"
8. Run "End_Benchmark"

A report is generated in the same folder as the workbook.

Code of module "modBench":

Option Explicit
Private Const CLT_1 = " 'CODE INSERTED BY MODBENCH"
Private Const CLT_2 = """ INSERTED BY MODBENCH"
Private Const CLT_3 = " 'PARTIAL CODE """
Private Const CLT_4 = "'MODBENCH TO INSERT PROCEDURE INFO START HERE"

Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long

Private p_count(10000) As Long
Private p_total_time(10000) As Currency
Private p_module_time(10000) As Currency
Private p_in_time(10000) As Currency

Private p_call_stack(10000) As Long
Private p_call_stack_indx As Long

Private t1 As Currency
Private t2 As Currency




Sub PrintBenchResults()
    Dim i As Long, j As Long, dTimerTmp() As Double, lMaxIndx As Long
    Dim m_PerfFrequency As Currency
    QueryPerformanceFrequency m_PerfFrequency

    ReDim dTimerTmp(UBound(dTimer))
    For i = 0 To UBound(dTimerTmp)
        dTimerTmp(i) = dTimer(i) / m_PerfFrequency * 1000
    Next
    Do
        lMaxIndx = 0
        For i = 1 To UBound(dTimerTmp)
            If dTimerTmp(i) > dTimerTmp(lMaxIndx) Then lMaxIndx = i
        Next
        If dTimerTmp(lMaxIndx) < -1000 Then Exit Do
        If lCount(lMaxIndx) > 0 Then
            Debug.Print Round(dTimerTmp(lMaxIndx), 1) & " ms (" & lCount(lMaxIndx) & " runs) " & vbTab & Round(dTimerTmp(lMaxIndx) / lCount(lMaxIndx), 3) & " ms per run" & vbTab & sProc(lMaxIndx)
        Else
            Debug.Print Round(dTimerTmp(lMaxIndx), 3) & " ms (" & lCount(lMaxIndx) & " runs) " & vbTab & sProc(lMaxIndx)
        End If
        dTimerTmp(lMaxIndx) = -1001
    Loop
End Sub

Sub p_out(P_id As Long)
    Dim time_out As Currency
    QueryPerformanceCounter time_out
    
    p_call_stack_indx = p_call_stack_indx - 1
    t1 = time_out - p_in_time(p_call_stack_indx)
    p_total_time(P_id) = p_total_time(P_id) + t1
    p_module_time(P_id) = p_module_time(P_id) + t1
    If p_call_stack_indx > 0 Then
        p_module_time(p_call_stack(p_call_stack_indx - 1)) = p_module_time(p_call_stack(p_call_stack_indx - 1)) - t1
    End If
End Sub

Sub p_in(P_id As Long)
    Dim time_in As Currency
    QueryPerformanceCounter time_in
    p_in_time(p_call_stack_indx) = time_in
    p_call_stack(p_call_stack_indx) = P_id
    p_call_stack_indx = p_call_stack_indx + 1
    p_count(P_id) = p_count(P_id) + 1
End Sub



Sub Start_Benchmark()
    Dim VBComp As VBIDE.VBComponent, ThisModule As VBIDE.CodeModule, i As Long, j As Long, ProcStartOffset As Long
    Dim p_index As Long
    Dim ProcedureKind As Long
    Dim ProcedureName As String
    Dim ProcStart As Long, ProcEnd As Long, ProcCodeEnd As Long
    Dim p_line As String, lPos As Long, p_type As String
    Dim p_code_insert() As String: ReDim p_code_insert(0)
    
    RemoveBenchCode
    p_index = 0
    For Each VBComp In ThisWorkbook.VBProject.VBComponents
        With VBComp.CodeModule
            If .Name <> "modBench" Then
                i = .CountOfDeclarationLines + 1
                While i < .CountOfLines
                    ProcedureName = .ProcOfLine(i, ProcedureKind)
                    ProcStart = .ProcBodyLine(ProcedureName, ProcedureKind)
                    ProcStartOffset = 1
                    While Right(RTrim(.Lines(ProcStart + ProcStartOffset - 1, 1)), 1) = "_"
                        ProcStartOffset = ProcStartOffset + 1
                    Wend
                    .InsertLines ProcStart + ProcStartOffset, "    p_in " & p_index & CLT_1
                    ProcEnd = i + .ProcCountLines(ProcedureName, ProcedureKind) - 1
                    ProcCodeEnd = ProcEnd
                    While Left(LTrim(.Lines(ProcCodeEnd, 1)), 4) <> "End "
                        ProcCodeEnd = ProcCodeEnd - 1
                    Wend
                    For j = ProcStart + ProcStartOffset To ProcCodeEnd - 1
                        p_line = " " & .Lines(j, 1) & " "
                        lPos = InStr(p_line, " Exit Function "): p_type = " Exit Function "
                        If lPos = 0 Then lPos = InStr(p_line, " Exit Sub "): p_type = " Exit Sub "
                        If lPos = 0 Then lPos = InStr(p_line, " Exit Property "): p_type = " Exit Property "
                        If lPos > 0 Then
                            p_line = Mid(p_line, 2, lPos - 1) & "modBench.p_out " & p_index & ": " & Mid(p_line, lPos + 1, Len(p_line)) & CLT_3 & "modBench.p_out " & p_index & ": " & CLT_2
                            .DeleteLines j, 1
                            .InsertLines j, p_line
                        End If
                    Next
                    .InsertLines ProcCodeEnd, "    p_out " & p_index & CLT_1
                    ProcCodeEnd = ProcCodeEnd + 1
                    ProcEnd = ProcEnd + 1
                    i = ProcEnd + 1
                    
                    ReDim Preserve p_code_insert(p_index + 2)
                    p_code_insert(p_index + 2) = "    p_names(" & p_index & ") = """ & VBComp.Name & "." & ProcedureName & """"
                    p_index = p_index + 1
                Wend
            Else
                Set ThisModule = VBComp.CodeModule
            End If
        End With
    Next
    p_index = p_index - 1
    If p_index < 0 Then Exit Sub
    p_code_insert(0) = "    p_max_index = " & p_index
    p_code_insert(1) = "    ReDim p_names(" & p_index & ") As String"
    For i = 0 To UBound(p_code_insert)
        p_code_insert(i) = p_code_insert(i) & Space(99 - Len(p_code_insert(i))) & CLT_1
    Next
    With ThisModule
        i = .CountOfDeclarationLines + 1
        While i < .CountOfLines
            If Right(.Lines(i, 1), Len(CLT_4)) = CLT_4 Then
                i = i + 1
                .InsertLines i, Join(p_code_insert, vbCrLf)
                Exit Sub
            End If
            i = i + 1
        Wend
    End With
End Sub

Sub RemoveBenchCode()
    Dim VBComp As VBIDE.VBComponent, i As Long, p_line As String, p_part As String, cit_pos As Long
    For Each VBComp In ThisWorkbook.VBProject.VBComponents
        With VBComp.CodeModule
            i = 1
            While i < .CountOfLines
                p_line = .Lines(i, 1)
                If Right(p_line, Len(CLT_1)) = CLT_1 Then
                    .DeleteLines i, 1
                    i = i - 1
                ElseIf Right(p_line, Len(CLT_2)) = CLT_2 Then
                    p_part = Left(p_line, Len(p_line) - Len(CLT_2))
                    cit_pos = InStrRev(p_part, """")
                    If cit_pos > 0 Then
                        If Right(Left(p_part, cit_pos), Len(CLT_3)) = CLT_3 Then
                            p_part = Right(p_part, Len(p_part) - cit_pos)
                            p_line = Left(p_line, Len(p_line) - Len(CLT_2) - Len(CLT_3) - Len(p_part))
                            p_line = Replace(p_line, p_part, "")
                            .DeleteLines i, 1
                            .InsertLines i, p_line
                        End If
                    End If
                End If
                i = i + 1
            Wend
        End With
    Next
End Sub

Sub End_Benchmark()
    Dim p_max_index As Long, i As Long, p_names() As String, sOutputFile As String, WBout As Workbook, WSout As Worksheet
    Dim fso As Object
    Dim SortOrder() As Long, tmpSort As Long, CntUsed As Long
    Dim IsSorted As Boolean
    p_max_index = 0
    ReDim p_names(0) As String

'MODBENCH TO INSERT PROCEDURE INFO START HERE
    
    CntUsed = 0
    ReDim SortOrder(0) As Long
    For i = 0 To p_max_index
        If p_count(i) > 0 Then
            ReDim Preserve SortOrder(CntUsed)
            SortOrder(CntUsed) = i
            CntUsed = CntUsed + 1
        End If
    Next
    IsSorted = False
    While Not IsSorted
        IsSorted = True
        i = 0
        While i <= CntUsed - 2
            If p_module_time(SortOrder(i)) < p_module_time(SortOrder(i + 1)) Then
                IsSorted = False
                tmpSort = SortOrder(i)
                SortOrder(i) = SortOrder(i + 1)
                SortOrder(i + 1) = tmpSort
            End If
            i = i + 1
        Wend
    Wend
    
    sOutputFile = ThisWorkbook.Path & "\Benchmark results for " & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".")) & "xlsx"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(sOutputFile) Then
        Application.DisplayAlerts = False
        Set WBout = Application.Workbooks.Open(sOutputFile)
        Application.DisplayAlerts = True
    Else
        Set WBout = Application.Workbooks.Add
        WBout.SaveAs sOutputFile
    End If
    Set WSout = WBout.Worksheets(1)
    FormatBlock WSout, CntUsed
    WSout.Cells(1, 1).Value = "Benchmark of " & ThisWorkbook.Name
    WSout.Cells(1, 6).Value = "D_Out:" & p_call_stack_indx
    WSout.Cells(2, 1).Value = Now()
    WSout.Cells(3, 3).Value = "Time including subroutines"
    WSout.Cells(3, 5).Value = "Time excluding subroutines"
    WSout.Cells(4, 1).Value = "Module"
    WSout.Cells(4, 2).Value = "No. runs"
    WSout.Cells(4, 3).Value = "Total run time"
    WSout.Cells(4, 4).Value = "Avg. time/run"
    WSout.Cells(4, 5).Value = "Total run time"
    WSout.Cells(4, 6).Value = "Avg. time/run"
    For i = 0 To CntUsed - 1
        WSout.Cells(5 + i, 1).Value = p_names(SortOrder(i))
        WSout.Cells(5 + i, 2).Value = p_count(SortOrder(i))
        FillWithFormat WSout.Cells(5 + i, 3), p_total_time(SortOrder(i))
        FillWithFormat WSout.Cells(5 + i, 4), p_total_time(SortOrder(i)) / p_count(SortOrder(i))
        FillWithFormat WSout.Cells(5 + i, 5), p_module_time(SortOrder(i))
        FillWithFormat WSout.Cells(5 + i, 6), p_module_time(SortOrder(i)) / p_count(SortOrder(i))
    Next
    WBout.Save
    RemoveBenchCode
    'WBout.Close True
End Sub
Public Sub FillWithFormat(rIn As Range, cCounter As Currency)
    Dim m_PerfFrequency As Currency, dTime As Double, unit As String, lDigits As Long, lMega As Long
    QueryPerformanceFrequency m_PerfFrequency
    dTime = cCounter / m_PerfFrequency * 1000000
    rIn.Value = dTime
    If dTime = 0 Then
        rIn.NumberFormat = "0"" s"""
    Else
        lMega = Int(Log(dTime) / Log(1000))
        If lMega < 0 Then lMega = 0
        lDigits = 3 * lMega + 2 - Int(Log(dTime) / Log(10))
        Select Case lMega
            Case 0: unit = "µs"
            Case 1: unit = "ms"
            Case 2: unit = "s"
            Case 3: unit = "ks"
        End Select
        If lDigits <= 0 Then
            rIn.NumberFormat = "0" & String(lMega, ",") & """ " & unit & """"
        Else
            rIn.NumberFormat = "0." & String(lDigits, "0") & String(lMega, ",") & """ " & unit & """"
        End If
    End If
End Sub
Public Function TimestringFromCounter(cCounter As Currency) As String
    Dim m_PerfFrequency As Currency, dTime As Double, unit As String, lDigits As Long, sFormatString
    QueryPerformanceFrequency m_PerfFrequency
    dTime = cCounter / m_PerfFrequency
    unit = "s"
    If dTime < 1 Then dTime = dTime * 1000: unit = "ms"
    If dTime < 1 Then dTime = dTime * 1000: unit = "µs"
    If dTime <= 0.005 Then
        TimestringFromCounter = "<0.01 µs"
    Else
        lDigits = 2 - Int(Log(dTime) / Log(10))
        If lDigits < 0 Then lDigits = 0
        sFormatString = "0"
        If lDigits > 0 Then sFormatString = "0." & String(lDigits, "0")
        TimestringFromCounter = Replace(Format(dTime, sFormatString) & " " & unit, ",", ".")
    End If
End Function

Sub FormatBlock(WS As Worksheet, lModuleLines As Long)
    WS.Range(WS.Cells(1, 1), WS.Cells(5 + lModuleLines, 1)).EntireRow.Insert Shift:=xlDown
    WS.Columns("A:A").ColumnWidth = 50
    WS.Columns("B:B").ColumnWidth = 7.86
    WS.Columns("C:F").ColumnWidth = 12.86
    WS.Range("A1").Font.Size = 14
    WS.Range("A2").NumberFormat = "yyyy/mm/dd hh:mm:ss"
    WS.Range("A2").HorizontalAlignment = xlLeft
    WS.Range("B:F").HorizontalAlignment = xlCenter
    WS.Range("C3:D3").Merge
    WS.Range("E3:F3").Merge
    With WS.Range("A1:F2").Interior
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -4.99893185216834E-02
    End With
    With WS.Range("A3:F4").Interior
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.599993896298105
    End With
    With WS.Range(WS.Cells(5, 1), WS.Cells(4 + lModuleLines, 6)).Interior
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.799981688894314
    End With
    With WS.Range(WS.Cells(3, 3), WS.Cells(4 + lModuleLines, 4))
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThin
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlThin
    End With
    With WS.Range(WS.Cells(1, 1), WS.Cells(4 + lModuleLines, 6))
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlMedium
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeTop).Weight = xlMedium
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlEdgeRight).Weight = xlMedium
    End With
    With Range("A2:F2")
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).Weight = xlMedium
    End With
End Sub