Question

我遇到了一个与VBA非常不寻常的错误，我现在正在努力两天。我有一个代码，用于更新要在Active-x下拉列表中显示的值，然后使用ListFillRange属性将它们分配给列表。不幸的是，每次运行它都会产生错误。我认为错误是由于在完成刷新之前我正在刷新的电源枢轴上运行一段代码引起的。该错误发生在lastRow函数的第9行，该函数选择电源枢轴中的单元格。在我注释掉刷新数据透视表的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

Answer 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

强制VBA等待电源枢轴完成刷新

1 个答案: