如何修改VBA宏实现对同文件夹所有文件运行Power Query

以下是修改后的VBA宏，可遍历当前Excel文件所在文件夹中的所有.xlsx文件，自动替换Power Query逻辑中的#3占位符并执行数据导入：

Sub Batch_Get_Data()
    Dim folderPath As String
    Dim fileName As String
    Dim baseFileName As String
    Dim pqFormula As String
    Dim queryName As String
    
    ' 获取当前工作簿所在文件夹路径
    folderPath = ThisWorkbook.Path & "\"
    ' 遍历文件夹内的xlsx文件
    fileName = Dir(folderPath & "*.xlsx")
    
    On Error GoTo ErrorHandler ' 错误处理
    
    Do While fileName <> ""
        ' 跳过当前工作簿本身
        If fileName <> ThisWorkbook.Name Then
            ' 获取不含扩展名的文件名（替换#3的内容）
            baseFileName = Left(fileName, InStr(fileName, ".xlsx") - 1)
            ' 生成唯一的查询名称
            queryName = "Query_" & baseFileName
            
            ' 构建Power Query公式，替换所有#3占位符
            pqFormula = "(""" & queryName & """,""let" & Chr(10) & _
                "  Source = Excel.Workbook(File.Contents(""" & folderPath & fileName & """), null, true)," & Chr(10) & _
                "  Navigation = Source{[Item = """ & baseFileName & """, Kind = ""Sheet""]}[Data]," & Chr(10) & _
                "  #""Promoted headers"" = Table.PromoteHeaders(Navigation, [PromoteAllScalars = true])," & Chr(10) & _
                "  #""Changed column type"" = Table.TransformColumnTypes(#""Promoted headers"", {""#"", type text}, {""Street "", type text}, {""Number"", Int64.Type}, {""Status"", type any}, {""Date"", type any})" & Chr(10) & _
                "in" & Chr(10) & "  #""Changed column type"""""")"
            
            ' 执行Power Query公式
            ExecuteExcel4Macro pqFormula
            
            ' 添加新工作表并导入数据
            ActiveWorkbook.Worksheets.Add
            With ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
                "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & queryName & ";Extended Properties=""""""" _
                , Destination:=Range("$A$1")).QueryTable
                .CommandType = xlCmdSql
                .CommandText = Array("SELECT * FROM [" & queryName & "]")
                .RowNumbers = False
                .FillAdjacentFormulas = False
                .PreserveFormatting = True
                .RefreshOnFileOpen = False
                .BackgroundQuery = True
                .RefreshStyle = xlInsertDeleteCells
                .SavePassword = False
                .SaveData = True
                .RefreshPeriod = False
                .PreserveColumnInfo = False
                .ListObject.DisplayName = "Table_" & baseFileName
                .Refresh BackgroundQuery:=False
            End With
        End If
        ' 获取下一个文件
        fileName = Dir()
    Loop
    
    Exit Sub
    
ErrorHandler:
    MsgBox "处理文件 " & fileName & " 时出错: " & Err.Description, vbExclamation
    Resume Next
End Sub

关键修改说明 #

• 遍历文件夹：使用Dir函数遍历当前工作簿所在文件夹的所有.xlsx文件，自动跳过当前工作簿本身
• 占位符替换：将原代码中所有#3占位符替换为当前处理文件的不含扩展名的名称，包括Power Query的文件路径、工作表引用、查询名称
• 唯一查询名：为每个文件生成唯一的查询名称（如Query_文件名），避免查询名称冲突
• 错误处理：新增错误捕获机制，单个文件处理失败时不会中断整个批量任务，会弹出错误提示并继续处理下一个文件
• 动态路径：使用ThisWorkbook.Path获取当前文件夹路径，无需硬编码固定路径，提升宏的通用性

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