强制VBA等待，直到电源枢轴完成刷新 [英] Force VBA to wait until power pivot finishes refreshing

问题描述

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

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

推荐答案

天哪，我已经弄清楚了.

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.

有人(我最终会)应该能够改善这一点，以便它处理多单元格范围.本质上，它等待每个单元依次完成计算.似乎我们使用的大多数PP查找公式都是分批完成的，因此每批只需要测试一个单元格即可.它的效率很高，但肯定可以利用优化.我会改进后再发贴.

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

这篇关于强制VBA等待，直到电源枢轴完成刷新的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！