Microsoft Excel - 64bit update for NullSkull "Identifying which formulas in Excel are slowing down workbook"

Asked By John Williams on 18-Apr-22 03:33 PM
Hi - there is VBA on this site to have Excel identify which formulas are slowing down the workbook.  Code is below but I don't know how to update it for 64bit.  Is there someone who can help with that?  Thank You!

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

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)
ro.Cells(1, 1).Value = rt.Worksheet.Name & "!" & rt.Address
ro.Cells(1, 2) = shortCalcTimer(rt, False)
Next c
Set timeSheet = ro

End Function

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)
Set rAll = ro
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
' 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.Add Key:=rKey, _
SortOn:=xlSortOnValues, Order:=xlDescending, _

.SetRange rAll
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
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

End Sub

Function shortCalcTimer(rt As Range, Optional bReport As Boolean = TrueAs 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
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

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