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 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 = cyTicks1 / cyFrequency
End Function

Sub RangeTimer()
 DoCalcTimer 1
End Sub
Sub SheetTimer()
 DoCalcTimer 2
End Sub
Sub RecalcTimer()
 DoCalcTimer 3
End Sub
Sub FullcalcTimer()
 DoCalcTimer 4
End Sub

Sub DoCalcTimer(jMethod As Long)
 Dim dTime As Double
 Dim dOvhd As Double
 Dim oRng As Range
 Dim oCell As Range
 Dim oArrRange As Range
 Dim sCalcType As String
 Dim lCalcSave As Long
 Dim bIterSave As Boolean
 '
 On Error GoTo Errhandl

' Initialize
 dTime = MicroTimer

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

 ' Switch off iteration.

 If Application.Iteration <> False Then
 Application.Iteration = False
 End If
 
 ' Max is used range.

 If Selection.Count > 1000 Then
 Set oRng = Intersect(Selection, Selection.Parent.UsedRange)
 Else
 Set oRng = Selection
 End If

 ' Include array cells outside selection.

 For Each oCell In oRng
 If oCell.HasArray Then
 If oArrRange Is Nothing Then
 Set oArrRange = oCell.CurrentArray
 End If
 If Intersect(oCell, oArrRange) Is Nothing Then
 Set oArrRange = oCell.CurrentArray
 Set oRng = Union(oRng, oArrRange)
 End If
 End If
 Next oCell

 sCalcType = "Calculate " & CStr(oRng.Count) & _
 " Cell(s) in Selected Range: "
 Case 2
 sCalcType = "Recalculate Sheet " & ActiveSheet.Name & ": "
 Case 3
 sCalcType = "Recalculate open workbooks: "
 Case 4
 sCalcType = "Full Calculate open workbooks: "
 End Select

' Get start time.
 dTime = MicroTimer
 Select Case jMethod
 Case 1
 If Val(Application.Version) >= 12 Then
 oRng.CalculateRowMajorOrder
 Else
 oRng.Calculate
 End If
 Case 2
 ActiveSheet.Calculate
 Case 3
 Application.Calculate
 Case 4
 Application.CalculateFull
 End Select

' Calculate duration.
 dTime = MicroTimer - dTime
 On Error GoTo 0

 dTime = Round(dTime, 5)
 MsgBox sCalcType & " " & CStr(dTime) & " Seconds", _
 vbOKOnly + vbInformation, "CalcTimer"

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 Sub
Errhandl:
 On Error GoTo 0
 MsgBox "Unable to Calculate " & sCalcType, _
 vbOKOnly + vbCritical, "CalcTimer"
 GoTo Finish
End Sub