Force VBA to wait until power pivot finishes refreshing

问题

I came across a very unusual error with VBA that I'm struggling with for two days now. I have a code that updates values to be shown in an Active-x dropdown list and then assigns them to the list using the ListFillRange property. Unfortunately every time I run it it generates an error. I presume the error is caused by running a piece of code on a power pivot that I'm refreshing before it completes the refresh. The error occurs in the 9th line of the lastRow function which selects a cell in the power pivot. The error no longer appears after I comment out the 5th line of the Sub which refreshes the pivot table. I guess the solution to this problem is forcing VBA to wait with going to the next step of the code until the refresh of the table is completed. I tried solving this problem by adding DoEvents and some other techniques that I've found online, but none of them worked. Any suggestions on tackling this problem would be highly appreciated. Thanks!

Sub updateList()
Dim listRangeEnd As Long

'Refresh pivot with all Promotion Weeks
'Clear all filters
Worksheets("Lookup").PivotTables("weeksList").ClearAllFilters
'Refresh pivot
Worksheets("Lookup").PivotTables("weeksList").RefreshTable


'Set listFillRange for the list
listRangeEnd = lastRow("Lookup", "D4")
Worksheets("Inputs").list.ListFillRange = "Lookup!D4:D" & listRangeEnd
Worksheets("Inputs").list.Value = Worksheets("Lookup").Range("D4").Value

End Sub


Public Function lastRow(sheet As String, Cell As String)
Dim Row As Long
Dim currentSheet As String

'Save the name of the currently selected sheet
currentSheet = ActiveSheet.Name

'Get the row number of the last non-empty cell in the column
Worksheets(sheet).Select
Worksheets(sheet).Range(Cell).Select
If Selection.Offset(1, 0).Value = "" Then
    Row = ActiveCell.Row
Else
    Row = Worksheets(sheet).Range(Cell).End(xlDown).Row
End If

'Go back to the previous sheet
Worksheets(inputSheet).Select

lastRow = Row

End Function

回答1:

Holy mother of goodness, I've figured it out.

It's not a perfect solution, it can be a little slow, but at least it works.

Someone (I will eventually) should be able to improve this so it deals with multi-cell ranges. Essentially it waits for each cell to finish calculating in turn. It seems most PP lookup formulas we use will finish in batches, so it only needs one cell from each batch to be tested. And it's fairly efficient, but it could definitely make use of optimisation. I'll post back as I improve on it.

Option Explicit
Option Compare Text

Function PP_Calcs_Finished() As Boolean
'v9.00 2016-11-28 10:39 - added PP_Calcs_Finished
'test for PowerPivot calculations to be completed

'tests any range names starting with prefix "PP_test_" to look for #GETTING_DATA in cell text
    Const cPPwait As String = "#GETTING_DATA"
'choose various cells in workbook and label ranges with prefix "PP_test_" to be checked for completion
    Const cPPprefix As String = "PP_test_"
'runs itself once per sRepeat seconds until test completes, this allows calcs to run in background
    Const sRepeat As Byte = 2
'Result: True means OK, False means not OK


Application.StatusBar = "PLEASE NOTE: readjusting lookups and formulas in the background, please be patient..."

'ensure calculations are automatic
Application.Calculation = xlCalculationAutomatic
Dim nm As Name, test_nm() As Name, n As Integer, nmax As Integer, ws As Worksheet

'find all test ranges
nmax = 0
'workbook scope
For Each nm In ThisWorkbook.Names
    If Left(nm.Name, 8) = cPPprefix Then
        nmax = nmax + 1
        ReDim Preserve test_nm(1 To nmax) As Name
        Set test_nm(nmax) = nm
    End If
Next nm
'worksheet scope
For Each ws In Worksheets
    For Each nm In ws.Names
        If Left(nm.Name, 8) = cPPprefix Then
            nmax = nmax + 1
            ReDim Preserve test_nm(1 To nmax) As Name
            Set test_nm(nmax) = nm
        End If
    Next nm
Next ws

'now test all ranges
Dim sSheetName As String, sRangeName As String
If nmax > 0 Then
    For n = 1 To nmax
        sSheetName = Mid(test_nm(n).RefersTo, 2, InStr(1, test_nm(n).RefersTo, "!") - 2)
        sRangeName = Mid(test_nm(n).RefersTo, InStr(1, test_nm(n).RefersTo, "!") + 1, 500)
        If Worksheets(sSheetName).Range(sRangeName).Cells(1).Text = cPPwait Then
        'still waiting, quit and test again in sRepeat seconds
            Application.OnTime Now + TimeSerial(0, 0, sRepeat), "PP_Calcs_Finished"
            Exit Function
        End If
    Next n
End If
Application.StatusBar = False
PP_Calcs_Finished = True
'Application.Calculate
End Function

来源：https://stackoverflow.com/questions/28573950/force-vba-to-wait-until-power-pivot-finishes-refreshing