在您的EXCEL/VBA代码中，有没有通用的基准测试代码可以用来限制性能消耗？ [英] Is there a generic benchmarking code that can be used to pin down performance hogs in your excel/vba code?

查看：29
本文介绍了在您的EXCEL/VBA代码中，有没有通用的基准测试代码可以用来限制性能消耗？的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

有一些很好的posts描述了衡量代码性能的两种主要方法。然而，如果您有一个多模块项目，其中的调用可能会在单个操作中执行数千个子例程调用，则很难确定性能高峰期在哪里。如何做到这一点？

VBA

我确实编写了一个通用的基准测试代码，可以添加到任何推荐答案项目中。它的工作方式是将代码添加到每个子/函数/属性的每个入口点和出口点，以总时间和不包括子例程的时间来衡量每个子程序所花费的时间。以下是它的使用方法：

  1. 在您的项目中创建一个名为modBch的新模块。命名是 重要。
  2. 将下面显示的代码复制到该模块。
  3. 确保Microsoft Visual Basic for Application Extensability 在VBA中引用
  4. 确保允许EXCEL允许对VBA的信任访问(&Q) 项目对象模型&Quot；(选项=信任中心=信任中的EXCEL设置 居中设置=>；宏设置
  5. 您的工作簿应另存为其他名称
  6. 运行Start_Benchmark&qot；
  7. 做一些任务。避免使用msg-box和similar以显示实际的cpu-hgs&qot；
  8. 运行；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屋！

查看全文
相关文章
其他开发最新文章
热门教程
热门工具
登录 关闭
扫码关注1秒登录
发送“验证码”获取 | 15天全站免登陆