Measuring VBA Code Execution Time

Measuring code execution time to the millisecond (or microsecond)

#If Win64 Then
    Private Declare PtrSafe Function getFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
    Private Declare PtrSafe Function getTickCount Lib "kernel32" Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
#Else
    Private Declare Function getFrequency Lib "kernel32" Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
    Private Declare Function getTickCount Lib "kernel32" Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long
#End If

Private m_cFrequency As Currency
Private m_CollTimeIt As Collection

Private Function MicroTimer() As Double  'Microseconds
    Dim cyTicks1 As Currency

    MicroTimer = 0

    If m_cFrequency = 0 Then getFrequency m_cFrequency
    getTickCount cyTicks1
    If m_cFrequency Then MicroTimer = cyTicks1 / m_cFrequency
End Function
Public Function TimeIt(ByVal sRoutine As String, Optional ByVal bOn As Boolean = True) As Long
    Dim iLevel As Integer

    If m_CollTimeIt Is Nothing Then
        Set m_CollTimeIt = New Collection
    End If

    iLevel = m_CollTimeIt.Count - 1
    If (iLevel < 0) Then iLevel = 0

    If bOn Then
        If ItemExists(m_CollTimeIt, sRoutine) Then
            Debug.Print sRoutine & " already exists in collection. You muffed somewhere."
            m_CollTimeIt.Remove sRoutine
        End If
        m_CollTimeIt.Add MicroTimer, sRoutine
    Else
        If ItemExists(m_CollTimeIt, sRoutine) Then
            TimeIt = (MicroTimer - m_CollTimeIt(sRoutine)) * 1000
            Debug.Print String(iLevel, vbTab) & Time, sRoutine & " took " & TimeString(TimeIt)
            m_CollTimeIt.Remove sRoutine
        Else
            Debug.Print sRoutine & " does not exist in collection. You muffed somewhere."
        End If
    End If

    If m_CollTimeIt.Count = 0 Then
        Set m_CollTimeIt = Nothing
    End If
End Function
private Property Get ItemExists(ByRef col As Collection, ByVal vIndex As Variant) As Boolean
    Dim vTemp As Variant

    On Error GoTo exit_here
    If Not col Is Nothing Then
        If col.Count > 0 Then
            If IsObject(col(1)) Then
                Set vTemp = col(vIndex)
            Else
                vTemp = col(vIndex)
            End If
            ItemExists = True
        End If
    End If
    
exit_here:
    Set vTemp = Nothing
End Property
Public Function TimeString(ByVal milliseconds As Double)
    Dim minutes As Long
    Dim seconds As Long
    Dim ms As Long
    Dim sTemp As String
    Dim sJoin() As String
    Dim iCount As Integer

    minutes = (milliseconds / 1000)  60
    seconds = (milliseconds  1000) Mod 60
    ms = milliseconds Mod 1000

    If minutes > 0 Then
        ReDim Preserve sJoin(iCount)
        sJoin(iCount) = minutes & " min"
        iCount = iCount + 1
    End If

    If seconds > 0 Then
        ReDim Preserve sJoin(iCount)
        sJoin(iCount) = seconds & " sec"
        iCount = iCount + 1
    End If

    If ms > 0 Then
        ReDim Preserve sJoin(iCount)
        sJoin(iCount) = ms & " ms"
        iCount = iCount + 1
    End If

    If minutes = 0 And seconds = 0 And ms = 0 Then
        TimeString = "0 ms"
    Else
        TimeString = Join(sJoin, ", ")
    End If
End Function

Example Usage :

Sub UnitTest1()
    TimeIt "Outer"
    Sleep 123
    TimeIt "Inner1"
    Sleep 456
    TimeIt "Inner2"
    Sleep 789
    TimeIt "Inner2", False
    TimeIt "Inner1", False
    TimeIt "Outer", False
End Sub

Output:
        9:59:09 AM          Inner2 took 789 ms
    9:59:09 AM              Inner1 took 1 sec, 246 ms
9:59:09 AM    Outer took 1 sec, 369 ms

Convert Milliseconds To Human Readable Time Using VBA

Public Function TimeString(ByVal milliseconds As Double) As String
 Dim minutes As Long
 Dim seconds As Long
 Dim ms As Long
 Dim sTemp As String
 Dim sJoin() As String
 Dim iCount As Integer

 minutes = (milliseconds / 1000)  60
 seconds = (milliseconds  1000) Mod 60
 ms = milliseconds Mod 1000

If minutes > 0 Then
 ReDim Preserve sJoin(iCount)
 sJoin(iCount) = minutes & " min"
 iCount = iCount + 1
 End If

 If seconds > 0 Then
 ReDim Preserve sJoin(iCount)
 sJoin(iCount) = seconds & " sec"
 iCount = iCount + 1
 End If

 If ms > 0 Then
 ReDim Preserve sJoin(iCount)
 sJoin(iCount) = ms & " ms"
 iCount = iCount + 1
 End If

 If minutes = 0 And seconds = 0 And ms = 0 Then
 TimeString = "0 ms"
 Else
 TimeString = Join(sJoin, ", ")
 End If
End Function

Usage :
TimeString(162523)

2 min, 42 sec, 523 ms