Excel VBA 重复导入XLSX数据至XLSM无需重命名查询名方法求助

核心原因 #

首次运行宏时会在当前工作簿创建名为Sheet1的Power Query查询、以及名为Sheet1的超级表，重复运行时重名对象冲突，导致创建失败。

修复方案 #

在创建查询和超级表前，先清理已存在的同名对象，同时将导入目标固定为cleaned工作表，避免依赖活动页。修改后的完整代码如下：

Sub ImportExportData()
    Dim ws As Worksheet
    Dim qry As WorkbookQuery
    Dim tbl As ListObject
    
    ' 1. 预处理：清理历史同名对象，避免重名冲突
    ' 删除已存在的同名查询
    On Error Resume Next
    For Each qry In ThisWorkbook.Queries
        If qry.Name = "Sheet1" Then
            qry.Delete
        End If
    Next qry
    ' 清除cleaned工作表原有数据和超级表
    Set ws = ThisWorkbook.Worksheets("cleaned")
    For Each tbl In ws.ListObjects
        If tbl.Name = "Sheet1" Then
            tbl.Delete
        End If
    Next tbl
    ws.UsedRange.Clear ' 清空残留数据
    On Error GoTo 0
    
    ' 2. 创建新查询导入数据
    ThisWorkbook.Queries.Add Name:="Sheet1", Formula:= _
        "let" & Chr(13) & "" & Chr(10) & "    Source = Excel.Workbook(File.Contents(""" & Environ("USERPROFILE") & "\Desktop\EXPORT DOCUMENTS\EXPORT.XLSX""), null, true)," & Chr(13) & "" & Chr(10) & "    Sheet1_Sheet = Source{[Item=""Sheet1"",Kind=""Sheet""]}[Data]," & Chr(13) & "" & Chr(10) & "    #""Promoted Headers"" = Table.PromoteHeaders(Sheet1_Sheet, [PromoteAllScalars=true])," & Chr(13) & "" & Chr(10) & "    #""Changed Type"" = Table.TransformColumnTypes(#""Promoted Headers"",{{""Vendor"", Int64.Type}, {""Reference"", type text}, {""Document Number"", Int64.Type}, {""Document Type"", type text}, {""Invoice Reference"", type text}, {""G/L Account"", Int64.Type}, {""Payment Method"", type text}, {""Payment terms"", Int64.Type}, {""Payment block"", type text}, {""Document Date"", type date}, {""Entry Date"", type date}, {""Posting Date"", type date}, {""Net Due Date"", type date}, {""Amount in Doc. Curr."", type number}, {""Document Currency"", type text}, {""Amount in Local Currency"", type number}, {""Text"", type text}, {""Document Header Text"", type text}, {""Assignment"", type text}, {""Clearing Date"", type date}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    #""Changed Type"""
    
    ' 3. 加载数据到cleaned工作表指定位置
    With ws.ListObjects.Add(SourceType:=0, Source:= _
        "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=Sheet1;Extended Properties=""""" _
        , Destination:=ws.Range("$B$1")).QueryTable
        .CommandType = xlCmdSql
        .CommandText = Array("SELECT * FROM [Sheet1]")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .ListObject.DisplayName = "Sheet1"
        .Refresh BackgroundQuery:=False
    End With
    
    ' 4. 样式及收尾设置
    ws.ListObjects("Sheet1").ShowAutoFilterDropDown = False
    ws.ListObjects("Sheet1").ShowTableStyleRowStripes = False
    ws.ListObjects("Sheet1").TableStyle = "TableStyleMedium4"
    Application.CommandBars("Queries and Connections").Visible = False
End Sub

关键改动说明 #

• 新增了查询和超级表的清理逻辑，用On Error Resume Next避免删除不存在的对象时报错
• 用ThisWorkbook.Worksheets("cleaned")固定导入目标页，不再依赖活动工作表，避免误导入其他页面
• 替换了硬编码的用户路径，用Environ("USERPROFILE")自动获取当前用户的根目录，更换电脑用户也可正常运行
• 合并了原来拆分的Power Query公式代码，避免拼接出错

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