Simple profiling in VBA

When you are optimizing for performance, the best approach is concentrate on the code where the most time is being spent. Even if you have a lot of experience, it's usually nearly impossible to guess where these hotspots are, and there's no reason to even attempt that when it's so easy to determine exactly what needs to be optimized by profiling your code.

VBA, of course, doesn't have a built in profiler. But it's really simple to roll your own, since fundamentally the only thing a profiler does is store the elapsed time between events in a data structure.

The simple implementation I made uses a static dictionary variable to store all its data. This is mostly for performance reasons: lookups in a dictionary are very fast. You don't want any part of the profiling code to run slowly, because that would greatly distort your results. You could also do this with a module-level variable, but I felt like having most of the implementation in a single function simplified the API and didn't sacrifice too much readability.

To use this profiler, add a call to Profile paFunctionEnter, "FunctionNameHere" to the start of the functions and subs that you want to measure, and a call to Profile paFunctionExit to all exit points. Since you have to mark the start and end points yourself, you will probably want to avoid adding profiling to trivial functions, which will just clutter up your output. You also might want to add profiling in the middle of a function; I've adopted the convention of prepending an ampersand to internal paFunctionEnters to distinguish them from actual functions in the output.

Enum ProfileAction
    paStart
    paEnd
    paFunctionEnter
    paFunctionExit
    paShowResults
End Enum

Enum ProfileFormat
    pfSelfTime = 0
    pfTotalTime = 1
    pfCallCount = 2
End Enum

Public Function Profile(a As ProfileAction, ParamArray args())
    Static sProf As Object
    Dim stack As String
    Dim elapsed As Single
    Dim calls As Variant
    
    If a <> paStart And sProf Is Nothing Then Exit Function
    
    If a = paStart Then
        Set sProf = CreateObject("Scripting.Dictionary")
        stack = args(0)
        sProf("_stack") = stack
        sProf("_t") = Timer
        sProf("_calls:" & stack) = 1
        Exit Function
    ElseIf a = paEnd Then
        Set sProf = Nothing
        Exit Function
    End If
    
    elapsed = Timer - sProf("_t")
    stack = sProf("_stack")
    Select Case a
        Case paFunctionEnter
            sProf(stack) = sProf(stack) + elapsed
            sProf("_stack") = stack & "/" & args(0)
            sProf("_parent:" & sProf("_stack")) = stack
            stack = sProf("_stack")
            calls = sProf("_calls:" & stack)
            If IsNull(calls) Then
                sProf("_calls:" & stack) = 1
            Else
                sProf("_calls:" & stack) = calls + 1
            End If
        
        Case paFunctionExit
            sProf(stack) = sProf(stack) + elapsed
            stack = sProf("_parent:" & stack)
            sProf("_stack") = stack
        
        Case paShowResults
            ProfileResults sProf, CLng(args(0))
    End Select
    
    sProf("_t") = Timer
End Function

Private Sub ProfileResults(prof As Object, fmt As ProfileFormat)
    Dim k As Variant
    Dim k2 As Variant
    Dim fmt_label As String
    
    For Each k In prof.Keys
        If Left(k, 1) <> "_" Then
            prof("_self:" & k) = prof(k)
            prof("_total:" & k) = 0!
        
            For Each k2 In prof.Keys
                If Left(k2, Len(k)) = k Then
                    prof("_total:" & k) = prof("_total:" & k) + prof(k2)
                End If
            Next
        End If
    Next
    
    fmt_label = Array("_self:", "_total:", "_calls:")(fmt)

    For Each k In prof.Keys
        If Left(k, Len(fmt_label)) = fmt_label Then
            Debug.Print Mid(k, Len(fmt_label) + 1) & ": " & prof(k)
        End If
    Next
End Sub

Example usage:

' Add calls to Profile paFunctionEnter and Profile paFunctionExit
' to the functions and subs that you are measuring.
Public Sub ProfilingExample()
    Dim x As Variant
    
    Profile paStart, "Test"
    x = SlowFunction(arg1, arg2, arg3)
    Profile paFunctionExit ' exit top level "Test" pseudofunction
    
    ' Profile paShowResults, pfCallCount
    ' Profile paShowResults, pfSelfTime
    Profile paShowResults, pfTotalTime
    Profile paEnd
End Sub

Here's what the output looks like. Since I called paShowResults with pfTotalTime, the values are the total seconds spent in each function. You can also get the number of calls and the "self" time, which doesn't include the time spent in sub-calls that are also profiled.

Test: 1.382813
Test/Filtered: 1.382813
Test/Filtered/GetScratchWorksheet: 0
Test/Filtered/CopyValues: 1.179688
Test/Filtered/CopyValues/FirstRow: 0
Test/Filtered/CopyValues/FirstCol: 0
Test/Filtered/CopyValues/SqueezeRange: 1.179688
Test/Filtered/CopyValues/SqueezeRange/FirstRow: 0
Test/Filtered/CopyValues/SqueezeRange/FirstCol: 0
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper: 1.179688
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea: 1.148438
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/LastCol: 0
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/&RowCollision: 0.6015625
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/&RowCollision/LastCol: 0.234375
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/&RowCollision/LastRow: 0.2578125
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/LastRow: 0
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/&ColumnCollision: 0.515625
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/&ColumnCollision/LastRow: 0.125
Test/Filtered/CopyValues/SqueezeRange/SqueezeRangeHelper/&ShiftArea/&ColumnCollision/LastCol: 0.203125
Test/Filtered/CopyValues/LastRow: 0
Test/Filtered/CopyValues/LastCol: 0