代码之家 › 专栏 › 技术社区 › mpmcderm

VBA测试另一个程序的速度

excel vba

0

mpmcderm · 技术社区 · 8 年前

我有两个竞争项目,我正在工作的项目。它是一种变更管理跟踪工具。它使用 application.undo 作用

我正在尝试编写第三个程序来进行更改,这样我就可以获得哪个程序运行得更快的数据,但是不适用于程序。

有没有想过如何绕过这个问题或解决方法?

Sub Counter()
     Dim i As Integer
     Worksheets("F&E List").Cells(6, 6).Value = 0
     For i = 1 To 5
         Worksheets("F&E List").Cells(6, 6).Value = i
         Application.Undo
     Next i
End Sub

这给了我运行时1004“对象'\u应用程序的方法撤消失败”

这和我从通用程序中得到的错误是一样的

1 回复 | 直到 8 年前

1

0

mpmcderm 8 年前

最后,我对代码进行了调整,以模拟两个程序中的撤销操作,从而在不实际启动应用程序的情况下测试其余代码。撤消命令。我认为两个程序中的撤销时间是相同的,因此它不会成为代码速度的一个因素(至少我可以控制一个),但这样我仍然可以比较代码。

这个子文件更新了电子表格并记录了每次迭代所花的时间,然后导出到另一个表格,这样我就可以在minitab中查看它了

 Sub Counter()
     Dim i As Integer
     Dim j As Integer
     Dim Time_Arr As Variant
     Worksheets("F&E List").Cells(4, 6).Value = 0
     ReDim Time_Arr(0) As Variant

     For i = 1 To 1000
         Worksheets("F&E List").Cells(4, 6).Value = i
         ReDim Preserve Time_Arr(i) As Variant
         Time_Arr(i) = Timer()
     Next i

     For i = 2 To UBound(Time_Arr)
         Worksheets("Time_Stamp").Cells(i, 1).Value = i
         Worksheets("Time_Stamp").Cells(i, 2).Value = Time_Arr(i) - Time_Arr(i - 1)
     Next i
 End Sub

这是主体代码,我还没有收录子程序,如果有人愿意我可以看一下。注意我是如何绕过应用程序的。撤消并创建一个虚假的旧值。我现在的目标是研究每个步骤的时间,以及如何进一步减少处理时间以减少延迟,因为这是日常使用表所需要的。

 Sub New_Process(Target As Range)

     Dim vStartTime As Variant
     Dim rng As Range
     Dim new_arr As Variant, old_arr As Variant, add_arr As Variant
     Dim add_val As String, r As Range
     Dim i As Integer, j As Integer

     On Error GoTo ErrHandler:

     Set rng = Intersect(Target, Range("FETable"))

     If rng Is Nothing Then
         Exit Sub
     End If

     Call Optimize_VBA

     new_arr = rng.Value
     add_val = rng.Address

     **'Application.Undo 'changed to a comment for testing purposes**

     **'old_arr = Range(add_val).Value**
     old_arr = -1

     Call Get_Add(add_arr, rng)

     Range(add_val).Value = new_arr

     If rng.Count = 1 Then

         If old_arr <> new_arr Then
             Call Check_Change(old_arr, new_arr, add_val)
         End If             
     Else
    For i = LBound(add_arr, 1) To UBound(add_arr, 1)
        For j = LBound(add_arr, 2) To UBound(add_arr, 2)
            If old_arr(i, j) <> new_arr(i, j) Then
                'Debug.Print i, j, add_arr(i, j), old_arr(i, j), new_arr(i, j)
                Call Check_Change(old_arr(i, j), new_arr(i, j), add_arr(i, j))
                 End If
             Next j
         Next i
     End If

     Call Return_Func

 ErrHandler:

     If Err.Number = 13 Then
         Call Return_Func
         Exit Sub
     End If
 End Sub