在您的EXCEL/VBA代码中,有没有通用的基准测试代码可以用来限制性能消耗? [英] Is there a generic benchmarking code that can be used to pin down performance hogs in your excel/vba code?
本文介绍了在您的EXCEL/VBA代码中,有没有通用的基准测试代码可以用来限制性能消耗?的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!
问题描述
有一些很好的posts描述了衡量代码性能的两种主要方法。然而,如果您有一个多模块项目,其中的调用可能会在单个操作中执行数千个子例程调用,则很难确定性能高峰期在哪里。如何做到这一点?
VBA
我确实编写了一个通用的基准测试代码,可以添加到任何推荐答案项目中。它的工作方式是将代码添加到每个子/函数/属性的每个入口点和出口点,以总时间和不包括子例程的时间来衡量每个子程序所花费的时间。以下是它的使用方法:
- 在您的项目中创建一个名为modBch的新模块。命名是 重要。
- 将下面显示的代码复制到该模块。
- 确保Microsoft Visual Basic for Application Extensability 在VBA中引用
- 确保允许EXCEL允许对VBA的信任访问(&Q) 项目对象模型&Quot;(选项=信任中心=信任中的EXCEL设置 居中设置=>;宏设置
- 您的工作簿应另存为其他名称
- 运行Start_Benchmark&qot;
- 做一些任务。避免使用msg-box和similar以显示实际的cpu-hgs&qot;
- 运行;End_Benchmark;
在工作簿所在的文件夹中生成报告。
模块";modBch";的编码:
Option Explicit
Private Const CLT_1 = " 'CODE INSERTED BY MODBENCH"
Private Const CLT_2 = """ INSERTED BY MODBENCH"
Private Const CLT_3 = " 'PARTIAL CODE """
Private Const CLT_4 = "'MODBENCH TO INSERT PROCEDURE INFO START HERE"
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As Currency) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As Currency) As Long
Private p_count(10000) As Long
Private p_total_time(10000) As Currency
Private p_module_time(10000) As Currency
Private p_in_time(10000) As Currency
Private p_call_stack(10000) As Long
Private p_call_stack_indx As Long
Private t1 As Currency
Private t2 As Currency
Sub PrintBenchResults()
Dim i As Long, j As Long, dTimerTmp() As Double, lMaxIndx As Long
Dim m_PerfFrequency As Currency
QueryPerformanceFrequency m_PerfFrequency
ReDim dTimerTmp(UBound(dTimer))
For i = 0 To UBound(dTimerTmp)
dTimerTmp(i) = dTimer(i) / m_PerfFrequency * 1000
Next
Do
lMaxIndx = 0
For i = 1 To UBound(dTimerTmp)
If dTimerTmp(i) > dTimerTmp(lMaxIndx) Then lMaxIndx = i
Next
If dTimerTmp(lMaxIndx) < -1000 Then Exit Do
If lCount(lMaxIndx) > 0 Then
Debug.Print Round(dTimerTmp(lMaxIndx), 1) & " ms (" & lCount(lMaxIndx) & " runs) " & vbTab & Round(dTimerTmp(lMaxIndx) / lCount(lMaxIndx), 3) & " ms per run" & vbTab & sProc(lMaxIndx)
Else
Debug.Print Round(dTimerTmp(lMaxIndx), 3) & " ms (" & lCount(lMaxIndx) & " runs) " & vbTab & sProc(lMaxIndx)
End If
dTimerTmp(lMaxIndx) = -1001
Loop
End Sub
Sub p_out(P_id As Long)
Dim time_out As Currency
QueryPerformanceCounter time_out
p_call_stack_indx = p_call_stack_indx - 1
t1 = time_out - p_in_time(p_call_stack_indx)
p_total_time(P_id) = p_total_time(P_id) + t1
p_module_time(P_id) = p_module_time(P_id) + t1
If p_call_stack_indx > 0 Then
p_module_time(p_call_stack(p_call_stack_indx - 1)) = p_module_time(p_call_stack(p_call_stack_indx - 1)) - t1
End If
End Sub
Sub p_in(P_id As Long)
Dim time_in As Currency
QueryPerformanceCounter time_in
p_in_time(p_call_stack_indx) = time_in
p_call_stack(p_call_stack_indx) = P_id
p_call_stack_indx = p_call_stack_indx + 1
p_count(P_id) = p_count(P_id) + 1
End Sub
Sub Start_Benchmark()
Dim VBComp As VBIDE.VBComponent, ThisModule As VBIDE.CodeModule, i As Long, j As Long, ProcStartOffset As Long
Dim p_index As Long
Dim ProcedureKind As Long
Dim ProcedureName As String
Dim ProcStart As Long, ProcEnd As Long, ProcCodeEnd As Long
Dim p_line As String, lPos As Long, p_type As String
Dim p_code_insert() As String: ReDim p_code_insert(0)
RemoveBenchCode
p_index = 0
For Each VBComp In ThisWorkbook.VBProject.VBComponents
With VBComp.CodeModule
If .Name <> "modBench" Then
i = .CountOfDeclarationLines + 1
While i < .CountOfLines
ProcedureName = .ProcOfLine(i, ProcedureKind)
ProcStart = .ProcBodyLine(ProcedureName, ProcedureKind)
ProcStartOffset = 1
While Right(RTrim(.Lines(ProcStart + ProcStartOffset - 1, 1)), 1) = "_"
ProcStartOffset = ProcStartOffset + 1
Wend
.InsertLines ProcStart + ProcStartOffset, " p_in " & p_index & CLT_1
ProcEnd = i + .ProcCountLines(ProcedureName, ProcedureKind) - 1
ProcCodeEnd = ProcEnd
While Left(LTrim(.Lines(ProcCodeEnd, 1)), 4) <> "End "
ProcCodeEnd = ProcCodeEnd - 1
Wend
For j = ProcStart + ProcStartOffset To ProcCodeEnd - 1
p_line = " " & .Lines(j, 1) & " "
lPos = InStr(p_line, " Exit Function "): p_type = " Exit Function "
If lPos = 0 Then lPos = InStr(p_line, " Exit Sub "): p_type = " Exit Sub "
If lPos = 0 Then lPos = InStr(p_line, " Exit Property "): p_type = " Exit Property "
If lPos > 0 Then
p_line = Mid(p_line, 2, lPos - 1) & "modBench.p_out " & p_index & ": " & Mid(p_line, lPos + 1, Len(p_line)) & CLT_3 & "modBench.p_out " & p_index & ": " & CLT_2
.DeleteLines j, 1
.InsertLines j, p_line
End If
Next
.InsertLines ProcCodeEnd, " p_out " & p_index & CLT_1
ProcCodeEnd = ProcCodeEnd + 1
ProcEnd = ProcEnd + 1
i = ProcEnd + 1
ReDim Preserve p_code_insert(p_index + 2)
p_code_insert(p_index + 2) = " p_names(" & p_index & ") = """ & VBComp.Name & "." & ProcedureName & """"
p_index = p_index + 1
Wend
Else
Set ThisModule = VBComp.CodeModule
End If
End With
Next
p_index = p_index - 1
If p_index < 0 Then Exit Sub
p_code_insert(0) = " p_max_index = " & p_index
p_code_insert(1) = " ReDim p_names(" & p_index & ") As String"
For i = 0 To UBound(p_code_insert)
p_code_insert(i) = p_code_insert(i) & Space(99 - Len(p_code_insert(i))) & CLT_1
Next
With ThisModule
i = .CountOfDeclarationLines + 1
While i < .CountOfLines
If Right(.Lines(i, 1), Len(CLT_4)) = CLT_4 Then
i = i + 1
.InsertLines i, Join(p_code_insert, vbCrLf)
Exit Sub
End If
i = i + 1
Wend
End With
End Sub
Sub RemoveBenchCode()
Dim VBComp As VBIDE.VBComponent, i As Long, p_line As String, p_part As String, cit_pos As Long
For Each VBComp In ThisWorkbook.VBProject.VBComponents
With VBComp.CodeModule
i = 1
While i < .CountOfLines
p_line = .Lines(i, 1)
If Right(p_line, Len(CLT_1)) = CLT_1 Then
.DeleteLines i, 1
i = i - 1
ElseIf Right(p_line, Len(CLT_2)) = CLT_2 Then
p_part = Left(p_line, Len(p_line) - Len(CLT_2))
cit_pos = InStrRev(p_part, """")
If cit_pos > 0 Then
If Right(Left(p_part, cit_pos), Len(CLT_3)) = CLT_3 Then
p_part = Right(p_part, Len(p_part) - cit_pos)
p_line = Left(p_line, Len(p_line) - Len(CLT_2) - Len(CLT_3) - Len(p_part))
p_line = Replace(p_line, p_part, "")
.DeleteLines i, 1
.InsertLines i, p_line
End If
End If
End If
i = i + 1
Wend
End With
Next
End Sub
Sub End_Benchmark()
Dim p_max_index As Long, i As Long, p_names() As String, sOutputFile As String, WBout As Workbook, WSout As Worksheet
Dim fso As Object
Dim SortOrder() As Long, tmpSort As Long, CntUsed As Long
Dim IsSorted As Boolean
p_max_index = 0
ReDim p_names(0) As String
'MODBENCH TO INSERT PROCEDURE INFO START HERE
CntUsed = 0
ReDim SortOrder(0) As Long
For i = 0 To p_max_index
If p_count(i) > 0 Then
ReDim Preserve SortOrder(CntUsed)
SortOrder(CntUsed) = i
CntUsed = CntUsed + 1
End If
Next
IsSorted = False
While Not IsSorted
IsSorted = True
i = 0
While i <= CntUsed - 2
If p_module_time(SortOrder(i)) < p_module_time(SortOrder(i + 1)) Then
IsSorted = False
tmpSort = SortOrder(i)
SortOrder(i) = SortOrder(i + 1)
SortOrder(i + 1) = tmpSort
End If
i = i + 1
Wend
Wend
sOutputFile = ThisWorkbook.Path & "Benchmark results for " & Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".")) & "xlsx"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(sOutputFile) Then
Application.DisplayAlerts = False
Set WBout = Application.Workbooks.Open(sOutputFile)
Application.DisplayAlerts = True
Else
Set WBout = Application.Workbooks.Add
WBout.SaveAs sOutputFile
End If
Set WSout = WBout.Worksheets(1)
FormatBlock WSout, CntUsed
WSout.Cells(1, 1).Value = "Benchmark of " & ThisWorkbook.Name
WSout.Cells(1, 6).Value = "D_Out:" & p_call_stack_indx
WSout.Cells(2, 1).Value = Now()
WSout.Cells(3, 3).Value = "Time including subroutines"
WSout.Cells(3, 5).Value = "Time excluding subroutines"
WSout.Cells(4, 1).Value = "Module"
WSout.Cells(4, 2).Value = "No. runs"
WSout.Cells(4, 3).Value = "Total run time"
WSout.Cells(4, 4).Value = "Avg. time/run"
WSout.Cells(4, 5).Value = "Total run time"
WSout.Cells(4, 6).Value = "Avg. time/run"
For i = 0 To CntUsed - 1
WSout.Cells(5 + i, 1).Value = p_names(SortOrder(i))
WSout.Cells(5 + i, 2).Value = p_count(SortOrder(i))
FillWithFormat WSout.Cells(5 + i, 3), p_total_time(SortOrder(i))
FillWithFormat WSout.Cells(5 + i, 4), p_total_time(SortOrder(i)) / p_count(SortOrder(i))
FillWithFormat WSout.Cells(5 + i, 5), p_module_time(SortOrder(i))
FillWithFormat WSout.Cells(5 + i, 6), p_module_time(SortOrder(i)) / p_count(SortOrder(i))
Next
WBout.Save
RemoveBenchCode
'WBout.Close True
End Sub
Public Sub FillWithFormat(rIn As Range, cCounter As Currency)
Dim m_PerfFrequency As Currency, dTime As Double, unit As String, lDigits As Long, lMega As Long
QueryPerformanceFrequency m_PerfFrequency
dTime = cCounter / m_PerfFrequency * 1000000
rIn.Value = dTime
If dTime = 0 Then
rIn.NumberFormat = "0"" s"""
Else
lMega = Int(Log(dTime) / Log(1000))
If lMega < 0 Then lMega = 0
lDigits = 3 * lMega + 2 - Int(Log(dTime) / Log(10))
Select Case lMega
Case 0: unit = "µs"
Case 1: unit = "ms"
Case 2: unit = "s"
Case 3: unit = "ks"
End Select
If lDigits <= 0 Then
rIn.NumberFormat = "0" & String(lMega, ",") & """ " & unit & """"
Else
rIn.NumberFormat = "0." & String(lDigits, "0") & String(lMega, ",") & """ " & unit & """"
End If
End If
End Sub
Public Function TimestringFromCounter(cCounter As Currency) As String
Dim m_PerfFrequency As Currency, dTime As Double, unit As String, lDigits As Long, sFormatString
QueryPerformanceFrequency m_PerfFrequency
dTime = cCounter / m_PerfFrequency
unit = "s"
If dTime < 1 Then dTime = dTime * 1000: unit = "ms"
If dTime < 1 Then dTime = dTime * 1000: unit = "µs"
If dTime <= 0.005 Then
TimestringFromCounter = "<0.01 µs"
Else
lDigits = 2 - Int(Log(dTime) / Log(10))
If lDigits < 0 Then lDigits = 0
sFormatString = "0"
If lDigits > 0 Then sFormatString = "0." & String(lDigits, "0")
TimestringFromCounter = Replace(Format(dTime, sFormatString) & " " & unit, ",", ".")
End If
End Function
Sub FormatBlock(WS As Worksheet, lModuleLines As Long)
WS.Range(WS.Cells(1, 1), WS.Cells(5 + lModuleLines, 1)).EntireRow.Insert Shift:=xlDown
WS.Columns("A:A").ColumnWidth = 50
WS.Columns("B:B").ColumnWidth = 7.86
WS.Columns("C:F").ColumnWidth = 12.86
WS.Range("A1").Font.Size = 14
WS.Range("A2").NumberFormat = "yyyy/mm/dd hh:mm:ss"
WS.Range("A2").HorizontalAlignment = xlLeft
WS.Range("B:F").HorizontalAlignment = xlCenter
WS.Range("C3:D3").Merge
WS.Range("E3:F3").Merge
With WS.Range("A1:F2").Interior
.ThemeColor = xlThemeColorDark1
.TintAndShade = -4.99893185216834E-02
End With
With WS.Range("A3:F4").Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.599993896298105
End With
With WS.Range(WS.Cells(5, 1), WS.Cells(4 + lModuleLines, 6)).Interior
.ThemeColor = xlThemeColorAccent6
.TintAndShade = 0.799981688894314
End With
With WS.Range(WS.Cells(3, 3), WS.Cells(4 + lModuleLines, 4))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlThin
End With
With WS.Range(WS.Cells(1, 1), WS.Cells(4 + lModuleLines, 6))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlEdgeRight).Weight = xlMedium
End With
With Range("A2:F2")
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlMedium
End With
End Sub
这篇关于在您的EXCEL/VBA代码中,有没有通用的基准测试代码可以用来限制性能消耗?的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!
查看全文