Execution Time Logging

1. First create a tab  called ExecutionTimes, and the headings as above.

2. Now create a module called Optimize, and insert the following Sub.

This code is available from optimizeExample.xlsm in the downloads section.

Function timeSheet(ws As Worksheet, routput As Range) As Range 
    Dim ro As Range 
    Dim c As Range, ct As Range, rt As Range, u As Range 

    ws.Activate 
    Set u = ws.UsedRange 
    Set ct = u.Resize(1) 
    Set ro = routput 

    For Each c In ct.Columns 
        Set ro = ro.Offset(1) 
        Set rt = c.Resize(u.Rows.Count) 
        rt.Select 
        ro.Cells(1, 1).Value = rt.Worksheet.Name & "!" & rt.Address
        ro.Cells(1, 2) = shortCalcTimer(rt, False) 
    Next c 
    Set timeSheet = ro 

End Function

This is our main function that will be called for each Sheet in your workbook. Starting at the place identified by the range routput, it will report on the address of each column in the sheet ws, along with how long it took to calculate each formula in seconds.

3. Now insert the following subs which will reference this.

Sub timeallsheets()
    Call timeloopSheets
End Sub

Sub timeloopSheets(Optional wsingle As Worksheet)
    
    Dim ws As Worksheet, ro As Range, rAll As Range
    Dim rKey As Range, r As Range, rSum As Range
    Const where = "ExecutionTimes!a1"
    
    Set ro = Range(where)
    ro.Worksheet.Cells.ClearContents
    Set rAll = ro
    'headers
    rAll.Cells(1, 1).Value = "address"
    rAll.Cells(1, 2).Value = "time"
    
    If wsingle Is Nothing Then
    ' all sheets
        For Each ws In Worksheets
            Set ro = timeSheet(ws, ro)
        Next ws
    Else
    ' or just a single one
        Set ro = timeSheet(wsingle, ro)
    End If
    
    'now sort results, if there are any
    
    If ro.Row > rAll.Row Then
        Set rAll = rAll.Resize(ro.Row - rAll.Row + 1, 2)
        Set rKey = rAll.Offset(1, 1).Resize(rAll.Rows.Count - 1, 1)
        ' sort highest to lowest execution time
        With rAll.Worksheet.Sort
            .SortFields.Clear
            .SortFields.Add Key:=rKey, _
            SortOn:=xlSortOnValues, Order:=xlDescending, _
                DataOption:=xlSortNormal
    
            .SetRange rAll
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        ' sum times
        Set rSum = rAll.Cells(1, 3)
        rSum.Formula = "=sum(" & rKey.Address & ")"
        ' %ages formulas
        For Each r In rKey.Cells
            r.Offset(, 1).Formula = "=" & r.Address & "/" & rSum.Address
            r.Offset(, 1).NumberFormat = "0.00%"
        Next r
        
    End If
    rAll.Worksheet.Activate

End Sub

4. Insert the code for timing the calculation.

Option Explicit
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

Function shortCalcTimer(rt As Range, Optional bReport As Boolean = True) As Double
    Dim dTime As Double
    Dim sCalcType As String
    Dim lCalcSave As Long
    Dim bIterSave As Boolean
    '
    On Error GoTo Errhandl


    ' Save calculation settings.
    lCalcSave = Application.Calculation
    bIterSave = Application.Iteration
    If Application.Calculation <> xlCalculationManual Then
        Application.Calculation = xlCalculationManual
    End If

    ' Switch off iteration.
    If Application.Iteration <> False Then
        Application.Iteration = False
    End If

' Get start time.
    dTime = MicroTimer
    If Val(Application.Version) >= 12 Then
        rt.CalculateRowMajorOrder
    Else
        rt.Calculate
    End If


' Calc duration.
    sCalcType = "Calculate " & CStr(rt.Count) & _
        " Cell(s) in Selected Range: " & rt.Address
    dTime = MicroTimer - dTime
    On Error GoTo 0

    dTime = Round(dTime, 5)
    If bReport Then
        MsgBox sCalcType & " " & CStr(dTime) & " Seconds"
    End If

    shortCalcTimer = dTime
Finish:

    ' Restore calculation settings.
    If Application.Calculation <> lCalcSave Then
         Application.Calculation = lCalcSave
    End If
    If Application.Iteration <> bIterSave Then
         Application.Calculation = bIterSave
    End If
    Exit Function
Errhandl:
    On Error GoTo 0
    MsgBox "Unable to Calculate " & sCalcType, _
        vbOKOnly + vbCritical, "CalcTimer"
    GoTo Finish
End Function
'
Function MicroTimer() As Double
'

' Returns seconds.
'
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency
    '
    MicroTimer = 0

' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency

' Get ticks.
    getTickCount cyTicks1

' Seconds
    If cyFrequency Then MicroTimer = cyhttps://ramblings.mcpher.com/wp-admin/edit.php?post_type=docsTicks1 / cyFrequency
End Function

Sub timeonesheet()
    Call timeloopSheets(Worksheets("LIsts"))
End Sub