强制VBA等待，直到权力枢纽完成刷新
我遇到了与VBA非常不寻常的错误，现在我正在挣扎两天。 我有一个代码，更新值将显示在Active-x下拉列表中，然后使用ListFillRange属性将它们分配给列表。 不幸的是每次运行它都会产生一个错误。 我认为这个错误是由于我在刷新完成之前刷新的一个关键点上的一段代码造成的。 这个错误发生在lastRow函数的第9行，这个函数在功率数据中select一个单元格。 在注释掉刷新数据透视表的Sub的第5行之后，错误不再出现。 我猜这个问题的解决scheme是迫使VBA等待代码的下一步，直到表刷新完成。 我试图通过添加DoEvents和我在网上find的一些其他技术来解决这个问题，但是没有一个能够工作。 任何build议来解决这个问题将不胜感激。 谢谢！
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
善良的圣母，我明白了。
这不是一个完美的解决scheme，它可能会有点慢，但至less是有效的。
有人（我会最终）应该能够改善这个，所以它处理多单元格范围。 本质上等待每个单元轮stream完成计算。 看来我们使用的大多数PP查找公式都是分批完成的，所以每批只需要一个单元格进行testing。 这是相当有效的，但它可以肯定利用优化。 我会回来，当我改善它。
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