强制 VBA 等到电源轴完成刷新

Posted 2023-03-25

【中文标题】强制 VBA 等到电源轴完成刷新

【英文标题】：Force VBA to wait until power pivot finishes refreshing

【发布时间】：2015-02-18 00:40:48

【问题描述】：

我在使用 VBA 时遇到了一个非常不寻常的错误，我已经为此苦苦挣扎了两天。我有一个代码可以更新要显示在 Active-x 下拉列表中的值，然后使用 ListFillRange 属性将它们分配给列表。 不幸的是，每次我运行它都会产生一个错误。我认为该错误是由于在完成刷新之前在我正在刷新的电源枢轴上运行一段代码引起的。错误发生在 lastRow 函数的第 9 行，该函数选择了 power pivot 中的一个单元格。在我注释掉刷新数据透视表的Sub 的第 5 行后，该错误不再出现。 我想这个问题的解决方案是强制 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

【问题讨论】：

你能指定哪个语句引发错误吗？是.Range(Cell).Select吗？ lastRow这个函数有什么作用？

是Worksheets(sheet).Range(Cell).Select 导致错误。

你可以尝试不使用使用Select吗？我不知道为什么会导致错误，但是如果工作表被锁定/保护，您可能无法Select 部分等。或者，使用THIS 方法查找最后一行。另外，错误信息是什么？ 1004？方法 _Range 失败？等等。

【参考方案1】：

圣母，我想通了。

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

有人（我最终会）应该能够改进这一点，以便它处理多单元格范围。本质上，它等待每个单元依次完成计算。似乎我们使用的大多数 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