强制 VBA 等待 Power Pivot 完成刷新

我在 VBA 中遇到了一个非常不寻常的错误，我已经为此苦苦挣扎了两天。我有一个代码，可以更新要在 Active-x 下拉列表中显示的值，然后使用ListFillRange财产。 不幸的是，每次我运行它时都会产生错误。我认为该错误是由于在电源枢轴上运行一段代码引起的，我在完成刷新之前正在刷新该代码。错误发生在 lastRow 函数的第 9 行，该函数选择 Power Pivot 中的一个单元格。注释掉第 5 行后，该错误不再出现Sub这会刷新数据透视表。 我想这个问题的解决方案是强制 VBA 等待代码的下一步，直到表刷新完成。我尝试通过添加来解决这个问题DoEvents以及我在网上找到的其他一些技术，但没有一个起作用。任何有关解决此问题的建议将不胜感激。谢谢！

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

善良的圣母，我已经明白了。

这不是一个完美的解决方案，可能有点慢，但至少它有效。

有人（我最终会）应该能够改进它，以便它可以处理多单元格范围。本质上它会等待每个单元格依次完成计算。看来我们使用的大多数 PP 查找公式都会分批完成，因此只需要每批中的一个单元格进行测试。它相当有效，但它绝对可以利用优化。当我改进它时我会回复。

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