Suspend VBA macro execution until calculations are finished

Question

I need to suspend macro execution until all calculations are finished.

I tried using loops with and without DoEvents checking CalculationState but the loop never ends.

Do Until Application.CalculationState = xlDone
    DoEvents
Loop

Answer 1

Have you looked at handling the application's AfterCalculate() event (see https://learn.microsoft.com/en-us/office/vba/api/excel.application.aftercalculate)?

You need to create a class which contains the Application object in order to access the handler. You can then call whatever routine you wish from there. If you had more than one routine to call depending on what is being calculated you could set, say, an enum to point to the right procedure. I've called this class cApp and skeleton code for that would be:

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

In this example, I have a one-row table that looks like this:

When the user enters a quantity, and the 'Price' cell calculates (A * B), a routine is called that populates the validation list in the 'Delivery' column. When a delivery option is selected, and the 'Cost' cell calculates (A * D), a routine is called that retrieves delivery times. It's a trite example, but should give you an idea on how to code it.

Code in a module looks like this:

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

The immediate window outputs the following:

RunMe() called...

Some user action confirmed.

RunMe() ended.

** No procedure is running **

SetDeliveryOptions() called...

Price is 25

SetDeliveryOptions() ended.

** No procedure is running **

SetTime() called...

Delivery Option is $7 - Next Day

SetTime() ended.

** No procedure is running **

Answer 2

What state is it in?

• List item xlCalculating 1 Calculations in process.
• List item xlDone 0 Calculations complete.
• List item xlPending 2 Changes that trigger calculation have been made, but a recalculation has not yet been performed.

It might help you determine what is happening on your worksheets.