A VBA performance class
Content
Introduction
If you write a lot of VBA code you probably sometimes run into performance
issues. A customer rings you and complains that the Excel file you built
for them does not perform well. In this little article I provide a bit of
VBA code that will help you trouble-shoot these performance issues.
Working principle
The code I'm about to show makes use of a very basic VBA principle: variables
declared at the routine level go out of scope as soon as the routine ends.
If such a variable points to an instance of a class, the class' terminate
event is fired. The system proposed here consists of these elements:
- A class module called clsPerf in which we keep score of the time
the class was initialised and which extends and fills an array with
values: the name of the calling routine, the start time and the elapsed
time
- A normal module modPerf with routines to reset the performance array,
to report the performance count and a couple of public variables to
keep track of what's been logged by the classes.
- A normal module modTimer which holds some API declarations and a
function to get a high resolution timestamp (courtesy Charles Williams)
- A bit of code in each of your routines you wish to troubleshoot.
I've kept that very simple. Since I plan to dump the performance data
into a worksheet and dumping a variant array to a worksheet is very fast,
I simply declared a public variant array in the modPerf module, along with
a couple of other variables:
'For clsPerf Class:
Public Const gbDebug As
Boolean = True
Public glPerfIndex As
Long
Public gvPerfResults()
As Variant
Public glDepth As
Long
I use glPerfIndex to record how many elements are in the variant array
and I use glDepth so I can indent the routine names according to where in
the call stack they are. gbDebug is a constant you can set to False to stop
using the performance class.
The clsPerf class
The clsPerf class is rather straightforward:
Option Explicit
'Which item of gvPerfResults "belongs" to this instance?
Dim mlIndex As
Long
'When did we start
Dim mdStartTime As
Double
Private Sub Class_Initialize()
'New item to keep track of, increase #
glPerfIndex = glPerfIndex + 1
'store which one is in this class instance
mlIndex = glPerfIndex
'Increase the depth to create an illusion
of a call stack
glDepth = glDepth + 1
If IsBounded(gvPerfResults)
Then
ReDim
Preserve gvPerfResults(1
To 3, 1 To glPerfIndex)
Else
ReDim
gvPerfResults(1 To 3, 1
To glPerfIndex)
End If
'Record when this instance was started
mdStartTime = dMicroTimer
End Sub
Public Sub SetRoutine(sRoutineName)
gvPerfResults(1, mlIndex) = String(glDepth
* 4, " ") & sRoutineName
End Sub
Private Sub Class_Terminate()
'Called automatically when the variable
pointing to this
'class' instance goes out of scope
'Outdent the call stack depth
glDepth = glDepth - 1
'Record starttime and run-time
gvPerfResults(2, mlIndex) = mdStartTime
gvPerfResults(3, mlIndex) = dMicroTimer - mdStartTime
End Sub
Private Function
IsBounded(vArray As Variant)
As Boolean
Dim lTest As
Long
On Error
Resume Next
lTest = UBound(vArray)
IsBounded = (Err.Number = 0)
End Function
The modPerf module
Some code in a normal module is needed to hold the array and for ease
of use I have also added a reporting routine:
Option Explicit
'For clsPerf Class:
Public Const gbDebug As
Boolean = True
Public glPerfIndex As
Long
Public gvPerfResults()
As Variant
Public glDepth As
Long
Sub Demo()
Dim cPerf As
clsPerf
ResetPerformance
If gbDebug
Then
Set cPerf
= New clsPerf
cPerf.SetRoutine "Demo"
End If
Application.OnTime Now, "ReportPerformance"
End Sub
Public Sub ResetPerformance()
glPerfIndex = 0
ReDim gvPerfResults(1
To 3, 1 To 1)
End Sub
Public Sub ReportPerformance()
Dim vNewPerf()
As Variant
Dim lRow As
Long
Dim lCol As
Long
ReDim vNewPerf(1
To UBound(gvPerfResults,
2) + 1, 1 To 3)
vNewPerf(1, 1) = "Routine"
vNewPerf(1, 2) = "Started at"
vNewPerf(1, 3) = "Time taken"
For lRow = 1
To UBound(gvPerfResults,
2)
For lCol
= 1 To 3
vNewPerf(lRow
+ 1, lCol) = gvPerfResults(lCol, lRow)
Next
Next
Workbooks.Add
With ActiveSheet
.Range("A1").Resize(UBound(vNewPerf,
1), 3).Value = vNewPerf
.UsedRange.EntireColumn.AutoFit
End With
AddPivot
End Sub
Sub AddPivot()
Dim oSh As
Worksheet
Set oSh = ActiveSheet
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase,
SourceData:= _
oSh.UsedRange.Address(external:=True),
Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="",
TableName:="PerfReport", DefaultVersion:= _
xlPivotTableVersion14
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3,
1)
ActiveSheet.Cells(3, 1).Select
With ActiveSheet.PivotTables(1)
With .PivotFields("Routine")
.Orientation
= xlRowField
.Position
= 1
End
With
.AddDataField ActiveSheet.PivotTables(1).PivotFields("Time
taken"), "Total Time taken", xlAverage
.PivotFields("Routine").AutoSort
xlDescending, "Total Time taken"
.AddDataField .PivotFields("Time
taken"), "Times called", xlCount
.RowAxisLayout xlTabularRow
.ColumnGrand =
False
.RowGrand = False
End With
End Sub
Basically all you need to do with this module is run the "ReportPerformance"
routine when you've run your code.
The modTimer module
This module contains some API declarations and a single routine to get
a timestamp:
Option Explicit
Option Private
Module
#If VBA7 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
Private Declare
PtrSafe Function timeGetTime
Lib "winmm.dll" () 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
Private Declare
Function timeGetTime Lib
"winmm.dll" () As Long
#End If
Private mdTime As
Double
Private msComment As
String
Public Function
dMicroTimer() As Double
'-------------------------------------------------------------------------
' Procedure : dMicroTimer
' Author : Charles Williams
www.decisionmodels.com
' Created : 15-June 2007
' Purpose : High resolution timer
'
Used for speed optimisation
'-------------------------------------------------------------------------
Dim cyTicks1
As Currency
Dim cyTicks2
As Currency
Static cyFrequency
As Currency
dMicroTimer = 0
If cyFrequency = 0
Then getFrequency cyFrequency
getTickCount cyTicks1
getTickCount cyTicks2
If cyTicks2 < cyTicks1
Then cyTicks2 = cyTicks1
If cyFrequency
Then dMicroTimer = cyTicks2 / cyFrequency
End Function
Implementing the
clsPerf class in your routines
Entry routines
In all your entry routines (routines you see as starting point of a core
functionality of your project), you might want to reset the variables of
the performance timer. This is done my calling the "ResetPerformance" subroutine
shown above.
All other routines
In all other routines you add these items:
- A variable declaration which is going to hold an instance of the
clsPerf class
- An If Then structure which tests for the gbDebug constant and if
True loads an instance of the clsPerf class and stores the routine name
in the class. The cPerf variable will automatically go out of scope
once the routine ends, which will fire the Terminate event of the class
so the end time can be recorded.
Sub Demo()
Dim cPerf As
clsPerf
If gbDebug
Then
Set cPerf
= New clsPerf
cPerf.SetRoutine "Demo"
End If
'Your code goes here
End Sub
That is all!
Make sure that you instantiate the performance class AFTER
you have gathered any user information through programming constructions
like GetOpenFileName or MsgBox or Userforms, otherwise you are just timing
how long the user takes to answer the questions your code is asking, rather
than testing the performance of your code.
Reporting the results
When your routine has ended, simply run the sub called "ReportPerformance"
in the modPerf module to get the full table of timings and a summary pivot
table.
Demo file
Download the demo
Conclusion
Hopefully I've helped you out a bit here by making troubleshooting for
performance a tiny bit easier. Let me know your findings!