如何用VBA强制刷新PowerQuery？宏刷新失效问题求助

问题背景 #

尝试用VBA宏自动化工作流时，无法更新PowerQuery表格，但手动点击功能区「全部刷新」按钮可以正常完成刷新。已尝试禁用后台刷新、添加等待循环避免宏跳过刷新操作，但问题仍未解决。以下是原宏代码：

Sub DepartmentalBudgetsMonthlyUpdate()
    Dim wb As Workbook
    Dim fName As String
    Dim folderPath As String
    Dim saveFolder As String
    Dim links As Variant
    Dim link As Variant
    Dim suffix As String
    Dim baseName As String
    Dim ws As Worksheet
    Dim qt As QueryTable
    Dim allDone As Boolean
    Dim lo As ListObject
    
    folderPath = "C:\Users\XXXX\Documents - Local\Departmental OpEx Reviews\New Opex Reviews\"
    saveFolder = "C:\Users\XXXX\Documents - Local\Departmental OpEx Reviews\08.25\"

    suffix = InputBox("Enter the month of the file:", "Month for File")
    
    If suffix = "" Then
        MsgBox "No month entered."
        Exit Sub
    End If

    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "The folder path does not exist: " & folderPath, vbCritical
        Exit Sub
    End If
    
    fName = Dir(folderPath & "*.xlsx")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Do While fName <> ""
        Set wb = Workbooks.Open(folderPath & fName, UpdateLinks:=3, ReadOnly:=True)
        
        wb.RefreshAll
        
        For Each ws In wb.Worksheets
            For Each qt In ws.QueryTables
                qt.BackgroundQuery = False
                qt.Refresh BackgroundQuery:=False
            Next qt
        Next ws
        
        For Each ws In wb.Worksheets
            For Each lo In ws.ListObjects
                On Error Resume Next
                If Not lo.QueryTable Is Nothing Then
                    lo.QueryTable.BackgroundQuery = False
                    lo.QueryTable.Refresh
                End If
                On Error GoTo 0
            Next lo
        Next ws
        
        Do
            allDone = True
            For Each ws In wb.Worksheets
                For Each qt In ws.QueryTables
                    If qt.Refreshing Then allDone = False
                Next qt
                For Each lo In ws.ListObjects
                    If Not lo.QueryTable Is Nothing Then
                        If lo.QueryTable.Refreshing Then allDone = False
                    End If
                Next lo
            Next ws
            DoEvents
        Loop Until allDone
    
        Application.CalculateFull
        Application.CalculateUntilAsyncQueriesDone
        
        links = wb.LinkSources(xlExcelLinks)
        
        If Not IsEmpty(links) Then
            For Each link In links
                wb.BreakLink Name:=link, Type:=xlLinkTypeExcelLinks
            Next link
        End If
        
        On Error Resume Next
        wb.Sheets("Transaction Detail").Protect Password:="password", _
        DrawingObjects:=True, Contents:=True, Scenarios:=True
        On Error GoTo 0
        
        baseName = Replace(Left(fName, Len(fName) - 5), "Master", "")
        wb.SaveAs Filename:=saveFolder & baseName & suffix & ".xlsx"
        wb.Close SaveChanges:=False
        Set wb = Nothing
        
        fName = Dir
    Loop
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
        
    MsgBox "All files updated, links broken, and saved."
    
End Sub

问题根源 #

原代码仅针对QueryTable和ListObject关联的QueryTable进行刷新，但PowerQuery的核心查询对象是WorkbookQuery，直接刷新表格对象可能无法触发底层PowerQuery查询的更新，而手动点击「全部刷新」会同时刷新这些WorkbookQuery对象。

修改后的宏代码 #

替换原代码中的刷新逻辑，直接遍历并刷新工作簿中的所有PowerQuery查询，同时确保等待所有刷新操作完成：

Sub DepartmentalBudgetsMonthlyUpdate()
    Dim wb As Workbook
    Dim fName As String
    Dim folderPath As String
    Dim saveFolder As String
    Dim links As Variant
    Dim link As Variant
    Dim suffix As String
    Dim baseName As String
    Dim ws As Worksheet
    Dim qt As QueryTable
    Dim allDone As Boolean
    Dim lo As ListObject
    Dim pqQuery As WorkbookQuery ' 新增PowerQuery查询对象
    
    folderPath = "C:\Users\XXXX\Documents - Local\Departmental OpEx Reviews\New Opex Reviews\"
    saveFolder = "C:\Users\XXXX\Documents - Local\Departmental OpEx Reviews\08.25\"

    suffix = InputBox("Enter the month of the file:", "Month for File")
    
    If suffix = "" Then
        MsgBox "No month entered."
        Exit Sub
    End If

    If Dir(folderPath, vbDirectory) = "" Then
        MsgBox "The folder path does not exist: " & folderPath, vbCritical
        Exit Sub
    End If
    
    fName = Dir(folderPath & "*.xlsx")

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False ' 禁用事件避免干扰刷新

    Do While fName <> ""
        Set wb = Workbooks.Open(folderPath & fName, UpdateLinks:=3, ReadOnly:=True)
        
        ' 1. 刷新所有PowerQuery核心查询
        For Each pqQuery In wb.Queries
            pqQuery.Refresh
        Next pqQuery
        
        ' 2. 刷新所有工作表中的QueryTable（确保表格数据同步）
        For Each ws In wb.Worksheets
            For Each qt In ws.QueryTables
                qt.BackgroundQuery = False
                qt.Refresh BackgroundQuery:=False
            Next qt
        Next ws
        
        ' 3. 刷新ListObject关联的QueryTable
        For Each ws In wb.Worksheets
            For Each lo In ws.ListObjects
                On Error Resume Next
                If Not lo.QueryTable Is Nothing Then
                    lo.QueryTable.BackgroundQuery = False
                    lo.QueryTable.Refresh
                End If
                On Error GoTo 0
            Next lo
        Next lo
        
        ' 等待所有刷新操作完成
        Do
            allDone = True
            ' 检查QueryTable是否在刷新
            For Each ws In wb.Worksheets
                For Each qt In ws.QueryTables
                    If qt.Refreshing Then allDone = False
                Next qt
                For Each lo In ws.ListObjects
                    If Not lo.QueryTable Is Nothing Then
                        If lo.QueryTable.Refreshing Then allDone = False
                    End If
                Next lo
            Next ws
            ' 检查PowerQuery查询是否在刷新
            For Each pqQuery In wb.Queries
                If pqQuery.IsRefreshing Then allDone = False
            Next pqQuery
            DoEvents
        Loop Until allDone
    
        Application.CalculateFull
        Application.CalculateUntilAsyncQueriesDone
        
        links = wb.LinkSources(xlExcelLinks)
        
        If Not IsEmpty(links) Then
            For Each link In links
                wb.BreakLink Name:=link, Type:=xlLinkTypeExcelLinks
            Next link
        End If
        
        On Error Resume Next
        wb.Sheets("Transaction Detail").Protect Password:="password", _
        DrawingObjects:=True, Contents:=True, Scenarios:=True
        On Error GoTo 0
        
        baseName = Replace(Left(fName, Len(fName) - 5), "Master", "")
        wb.SaveAs Filename:=saveFolder & baseName & suffix & ".xlsx"
        wb.Close SaveChanges:=False
        Set wb = Nothing
        
        fName = Dir
    Loop
        
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True ' 恢复事件
        
    MsgBox "All files updated, links broken, and saved."
    
End Sub

关键改动说明 #

1. 新增WorkbookQuery对象遍历：直接刷新PowerQuery的核心查询，这是手动「全部刷新」触发的关键操作，原代码缺失这一步。
2. 禁用Application.EnableEvents：避免刷新过程中触发不必要的工作表事件，干扰刷新流程。
3. 补充PowerQuery查询刷新状态检查：在等待循环中加入pqQuery.IsRefreshing判断，确保所有PowerQuery操作完成后再执行后续步骤。
4. 调整刷新顺序：先刷新底层PowerQuery查询，再同步刷新表格对象，保证数据流向正确。

内容的提问来源于stack exchange，提问作者Justin Parouty