暂停 VBA 宏执行，直到计算完成

Question

我需要暂停宏执行，直到所有计算完成。

我尝试使用带和不带DoEvents 的循环检查CalculationState，但循环永远不会结束。

Do Until Application.CalculationState = xlDone
    DoEvents
Loop

Answer 1

您是否考虑过处理应用程序的AfterCalculate() 事件（请参阅https://docs.microsoft.com/en-us/office/vba/api/excel.application.aftercalculate）？

您需要创建一个包含Application 对象的类才能访问处理程序。然后，您可以从那里调用您希望的任何例程。如果您有多个例程要调用，具体取决于正在计算的内容，您可以设置一个枚举来指向正确的过程。我已经将这个类称为 cApp，其骨架代码将是：

Option Explicit

Public Enum ProcAferCalcCode
    None
    DeliveryProc
    TimeProc
End Enum

Private WithEvents mApp As Application
Private mProcAfterCalcCode As ProcAferCalcCode

Public Property Let ProcAfterCalc(RHS As ProcAferCalcCode)
    mProcAfterCalcCode = RHS
End Property


Private Sub Class_Initialize()
    mProcAfterCalcCode = None
    Set mApp = Application
End Sub

Private Sub mApp_AfterCalculate()
    Select Case mProcAfterCalcCode
        Case DeliveryProc
            SetDeliveryOptions
        Case TimeProc
            SetTime
    End Select
End Sub

在此示例中，我有一个如下所示的单行表：

当用户输入数量并且“价格”单元格计算 (A * B) 时，将调用一个例程来填充“交货”列中的验证列表。选择递送选项后，“成本”单元格计算（A * D），调用一个例程检索交货时间。这是一个陈词滥调的例子，但应该让您了解如何编写代码。

模块中的代码如下所示：

Option Explicit

Private mApp As cApp

Public Sub RunMe()
    
    Debug.Print "RunMe() called..."
    
    If MsgBox("Ready to enter qty?", vbYesNo) = vbYes Then
        Debug.Print "Some user action confirmed."
        Set mApp = New cApp
        mApp.ProcAfterCalc = DeliveryProc
    End If
    
    Debug.Print "RunMe() ended."
    Debug.Print "** No procedure is running **" & vbNewLine
        
End Sub

Public Sub SetDeliveryOptions()
    Dim cell As Range
    Dim del As String
    
    Debug.Print "SetDeliveryOptions() called..."
    
    mApp.ProcAfterCalc = None
    
    Set cell = Sheet1.ListObjects("Table1").ListColumns("Price").DataBodyRange
    Debug.Print "Price is " & cell.Value2
    
    'Mimic some task.
    Select Case cell.Value2
        Case 0
            del = vbNullString
        Case Is < 5
            del = "$5 - Standard"
        Case Is < 10
            del = "$5 - Standard, $6 - Express"
        Case Else
            del = "$5 - Standard, $6 - Express, $7 - Next Day"
    End Select
    
    With cell.Offset(, 1)
        .Value = Empty
        With .Validation
            .Delete
            .Add xlValidateList, xlValidAlertStop, xlBetween, del
            .IgnoreBlank = True
            .InCellDropdown = True
            .InputTitle = ""
            .ErrorTitle = ""
            .InputMessage = ""
            .ErrorMessage = ""
            .ShowInput = True
            .ShowError = True
        End With
    End With
    
    mApp.ProcAfterCalc = TimeProc
    Debug.Print "SetDeliveryOptions() ended."
    Debug.Print "** No procedure is running **" & vbNewLine
    
End Sub

Public Sub SetTime()
    Dim cell As Range
    Dim d As Long
    
    Debug.Print "SetTime() called..."
    
    mApp.ProcAfterCalc = None
    
    Set cell = Sheet1.ListObjects("Table1").ListColumns("Delivery").DataBodyRange
    Debug.Print "Delivery Option is " & cell.Value
    
    'Mimic some other task.
    Select Case cell.Value2
        Case Is = "$5 - Standard"
            d = Int((10 - 5 + 1) * Rnd + 5)
        Case Is = "$6 - Express"
            d = Int((5 - 2 + 1) * Rnd + 2)
        Case Is = "$7 - Next Day"
            d = 1
        Case Else
            d = 0
    End Select
    
    cell.Offset(, 1) = d
    
    Debug.Print "SetTime() ended."
    Debug.Print "** No procedure is running **" & vbNewLine
    
End Sub

即时窗口输出以下内容：

RunMe() 调用...

已确认某些用户操作。

RunMe() 结束。

** 没有程序正在运行 **

SetDeliveryOptions() 调用...

价格是25

SetDeliveryOptions() 结束。

** 没有程序正在运行 **

SetTime() 调用...

送货选项为 7 美元 - 次日

SetTime() 结束。

** 没有程序正在运行 **

Answer 2

它处于什么状态？

• 列表项 xlCalculating 1 正在计算。
• 列表项 xlDone 0 计算完成。
• 列表项 xlPending 2 已进行触发计算的更改，但尚未执行重新计算。

它可能会帮助您确定工作表上发生了什么。