Een klasse om VBA performance te meten

Inhoud

Inleiding
Principe
Waar wordt de performance data bewaard
De clsPerf klasse
De modPerf module
De modTimer module
De clsPerf klasse in jouw subroutines implementeren
De resultaten rapporteren
Demo bestand
Conclusie

Inleiding

Als je veel code schrijft in VBA dan gebeurt het vast wel eens dat je aanloopt tegen performance problemen. Een klant belt op en klaagt dat het Excel model dat jij hebt gebouwd traag reageert. In dit korte artikel toon ik wat VBA code die helpt bij het trouble-shooten van trage VBA routines.

Principe

De code di ik zodadelijk laat zien maakt gebruik van een basisprincipe van de VBA compiler: Variabelen die gedeclareerd zijn op het subroutine niveau verliezen hun waarde als de routine wordt beëindigd. Als een dergelijke variabele verwijst naar een instantie van een klasse, dan zal het betekenen dat die klasse uit het geheugen gehaald wordt en dat daardoor het terminate event wordt aangeroepen. Het voorgestelde systeem bevat de volgende elementen:

Een klasse module genaamd clsPerf waarin we bijhouden op welk moment de klasse in het geheugen geladen werd en welke tevens een array bevat met de naam van de aanroepende routine de starttijd en de verstreken tijd
Een normale module modPerf die routines bevat die de performance array reset, de performance matrix rapporteert en een paar pulic variabelen die bijhouden wat er door de klasses is gelogd.
Een normale module modTimer die enkele API declaraties en een functie bevate om een hoge resolutie timer te verkrijgen (Met dank aan Charles Williams)
Wat code in iedere subroutine die je wilt timen.

Waar wordt de performance data bewaard

Ik heb dat deel erg simpel gehouden. Omdat ik van plan ben de data in een werkblad te dumpen en omdat dat heel snel gaat met een array gebruik ik een array variabele om deze gegevens tijdens het gebruik van de klasse te bewaren. De module bevat daarom een publieke array variabele en nog een paar andere hulp variabelen:

'For clsPerf Class:
Public Const gbDebug As Boolean = True
Public glPerfIndex As Long
Public gvPerfResults() As Variant
Public glDepth As Long

Ik gebruik glPerfIndex om het aantal elementen in de variant array bij te houden en ik gebruik glDepth om later de routine namen in te kunnen laten springen conform hun plaats in de "call stack". gbDebug is een constante die je op false kunt zetten om de performance klasse niet langer te gebruiken.

De clsPerf klasse

De clsPerf klasse is eigenlijk heel eenvoudig:

Option Explicit

'Welk element van gvPerfResults "hoort" bij deze instantie?
Dim mlIndex As Long

'Wanneer zijn we gestart
Dim mdStartTime As Double

Private Sub Class_Initialize()
    'Een nieuw element om te gaan bijhouden, verhoog het index getal
    glPerfIndex = glPerfIndex + 1
    'Houdt bij bij welke index deze klasse hoort
    mlIndex = glPerfIndex
    'Verhoog de diepte zodat we een illusie van een call stack creeeren
    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
    'Wat is de starttijd van deze instantie
    mdStartTime = dMicroTimer
End Sub

Public Sub SetRoutine(sRoutineName)
    gvPerfResults(1, mlIndex) = String(glDepth * 4, " ") & sRoutineName
End Sub

Private Sub Class_Terminate()
    'Automatisch aangeroepen zodra de variabele die naar deze instantie verwijst
    'out of scope gaat

    'Verklein de call stack diepte weer
    glDepth = glDepth - 1
    'Schrijf de start- en eindtijd weg
    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

De modPerf module

Er is wat code nodig in een normale module die de array met meetresultaten vasthoudt. Tevens bevat deze module een routine voor de rapportage van de resultaten:

Option Explicit

'Tbv de clsPerf klasse:
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

In principe is alles wat je uit deze module hoeft te doen het uitvoeren van de routine "ReportPerformance" nadat je jouw code hebt uit laten voeren.

De modTimer module

Deze module bevat enkele Windows API declaraties en een enkele subroutine die een timestamp ophaalt:

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

De clsPerf klasse in jouw subroutines implementeren

Start routines

In al je startroutines (routines die jij beschouwd als het beginpunt van kernfunctionaliteit van je VBA project)zal je de performance timer willen resetten. Dit doe je door de routine "ResetPerformance" aan te roepen die hierboven is getoond. Tevens voeg je toe wat onder "Alle andere routines" staat.

Alle andere routines

Aan alle routines waar je de performance wilt weten voeg je het volgende toe:

Een variable declaratie die naar de instantie van de clsPerf klasse gaat verwijzen
Een If Then structuur die test op de waarde van de constante gbDebug en die bij "True" de instantie van de clsPerf klasse laadt en de routine naam eraan doorgeeft. De cPerf variable cal automatisch worden gereset zodra de subroutine eindigt waarna het Terminate event van de klasse ervoor zorgt dat de tijd wordt vastgelegd..

Sub Demo()
    Dim cPerf As clsPerf
    If gbDebug Then
        Set cPerf = New clsPerf
        cPerf.SetRoutine "Demo"
    End If
    'Jouw code komt hier
End Sub

Dat is alles!

Zorg ervoor dat je clsPerf instantieert nadat je eventuele informatie van de gebruiker hebt opgevraagd, anders meet je de responstijd van de gebruiker. Dus zorg dat constructies als GetOpenFileName of MsgBox of Userforms, komen voor dat instantieren.

De resultaten rapporteren

Zodar je laatste routine geeindigd is kan je eenvoudig de routine "ReportPerformance" in modPerf aanroepen om een draaitabel met de meetresultaten te laten maken.

Demo bestand

Download het demo bestand

Conclusie

Ik hoop dat ik een beetje hulp heb kunnen bieden door het torubleshooten van de performance van je VBA project te vergemakkelijken. Laat maar weten wat je ervaringen hiermee zijn!

Vragen, suggesties en opmerkingen

Heeft u vragen, suggesties of opmerkingen? Gebruik dan dit formulier.

Mocht uw vraag niet direct relevant zijn voor deze pagina, maar een algemene Excel vraag betreffen, dan adviseer ik om deze hier te stellen: excelexperts.nl/forum/index.php.