Измерение производительности макросов (улучшение)

Предыдущий способ измерения производительности макросов был основан на использовании объекта Timer. Сегодня я хочу поделиться более совершенным инструментом для этой задачи, использующим функции WinAPI. Как и в прошлый раз замер производительности реализован с помощью класса, имеющего два метода Run и StopCounter, соответственно для запуска и остановки счётчика. При запуске можно задать имя процедуры производительность которой измеряется или любой другой поясняющий текст. Результат выводится в ImmediateWindow. Огромная благодарность пользователю karlex с форума bit.pirit за опубликованный код, на основе которого я сделал этот класс.

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
16 
17 
18 
19 
20 
21 
22 
23 
24 
25 
26 
27 
28 
29 
30 
31 
32 
33 
34 
35 
36 
37 
38 
39 
40 
41 
42 
43 
44 
45 
46 
47 
48 
49 
50 
51 
52 
53 
54 
55 
56 
57 
58 
59 
60 
61 
62 
63 
64 
65 
66 
67 
68 
69 
70 
71 
72 
73 
74 
75 
76 
77 
78 
79 
Option Explicit

'апи функция для получения значения счетчика
Private Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As LARGE_INTEGER) As Long

'апи функция для получения значения частоты
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As LARGE_INTEGER) As Long

'апи функция для копирования области памяти
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'структура для хранения 64-разрядного числа
Private Type LARGE_INTEGER
    LowPart As Long
    HighPart As Long
End Type

Dim T As Long, _
    liFrequency As LARGE_INTEGER, _
    liStart As LARGE_INTEGER, _
    liStop As LARGE_INTEGER
    
Dim cuFrequency As Currency, cuStart As Currency, cuStop As Currency

'Имя процедуры, вызвавшей счётчик
Private m_ProcName As String

'Состояние счётчика производительности
Private m_CounterEnabled As Boolean

Public Property Get Enabled() As Boolean
    Enabled = m_CounterEnabled
End Property

'Запуск счётчика производительности
Public Sub Run(Optional ByVal ProcName As String = "")
    m_CounterEnabled = QueryPerformanceFrequency(liFrequency) <> 0
    If m_CounterEnabled Then
        'конвертировать 64-разрядное число в тип currency
        cuFrequency = LargeIntToCurrency(liFrequency)
        
        'получить количество "тиков"
        QueryPerformanceCounter liStart
    Else
        Debug.Print "Ваше аппаратное обеспечение не поддерживает счетчик производительности высокой точности!"
    End If
     m_ProcName = ProcName
End Sub

'Остановка счётчика производительности
Public Sub StopCounter()
    If m_CounterEnabled Then
        'получить количество "тиков"
        QueryPerformanceCounter liStop
        
        'конвертировать 64-разрядное число в тип currency
        cuStart = LargeIntToCurrency(liStart)
        cuStop = LargeIntToCurrency(liStop)
        
        'вычислить как много времени затрачено, и показать результат
        DebugPrint CStr(Round((cuStop - cuStart) / cuFrequency, 10))
    End If
End Sub

Private Sub DebugPrint(ByVal CounterValue As String)
    Dim s As String
    If Len(m_ProcName) > 0 Then s = "Имя процедуры: " & m_ProcName & vbCr
    s = s & "Длительность: " & CounterValue & " секунд."
    Debug.Print s
End Sub

'функция для конвертирования 64-разрядного числа в тип currency
Private Function LargeIntToCurrency(liInput As LARGE_INTEGER) As Currency
          'копировать 8 байт из 64-разрядного в currency
    CopyMemory LargeIntToCurrency, liInput, LenB(liInput)
    
    'adjust it - хз =)
    LargeIntToCurrency = LargeIntToCurrency * 10000
End Function

Скачать модуль класса Тест производительности перебора ячеек таблицы двумя разными способами: циклом For Each...Next и циклом Do Until...Loop

 1 
 2 
 3 
 4 
 5 
 6 
 7 
 8 
 9 
10 
11 
12 
13 
14 
15 
Sub test()
    Dim pc As New clPerformanceCounter
    Dim i As Integer
    Dim ocell As Cell
    pc.Run "Перебор ячеек циклом Do loop"
'    pc.Run "Перебор ячеек циклом For Each"
    Set ocell = ActiveDocument.Tables(1).Range.Cells(1)
    Do Until ocell Is Nothing
        Set ocell = ocell.Next
    Loop
'    For Each ocell In ActiveDocument.Tables(1).Range.Cells
'
'    Next
    pc.StopCounter
End Sub

Результат:

Имя процедуры: Перебор ячеек циклом For Each Длительность: 0,1546585742 секунд. Имя процедуры: Перебор ячеек циклом Do loop Длительность: 0,1063016398 секунд.