求实现多工作簿多表格数据追加至当前工作簿Data Model的VBA代码

前置要求 #

• 启用Excel的Power Pivot功能（文件→选项→自定义功能区→勾选「Power Pivot」确定即可）
• 所有待导入的源表格结构完全一致：字段顺序、字段名称、数据类型必须匹配
• 运行代码前请先保存当前目标工作簿，避免异常造成数据丢失

代码实现 #

Sub 批量追加数据到DataModel()
    Dim sourceFiles As Variant
    Dim wbSource As Workbook
    Dim ws As Worksheet
    Dim srcData As Range
    Dim tbl As ListObject
    Dim modelTable As ModelTable
    Dim hasHeader As Boolean
    Dim i As Long
    Dim tempWs As Worksheet
    
    ' 选择需要导入的源工作簿
    sourceFiles = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xlsx; *.xls; *.xlsm), *.xlsx; *.xls; *.xlsm", Title:="选择需要导入的工作簿", MultiSelect:=True)
    If IsArray(sourceFiles) = False Then Exit Sub ' 用户取消选择则退出
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    hasHeader = False ' 标记是否已经写入过表头
    
    For i = LBound(sourceFiles) To UBound(sourceFiles)
        Set wbSource = Workbooks.Open(Filename:=sourceFiles(i), ReadOnly:=True)
        
        For Each ws In wbSource.Worksheets
            ' 跳过空表
            If ws.UsedRange.Rows.Count > 1 Then
                ' 获取当前工作表的有效数据范围
                Set srcData = ws.UsedRange
                
                ' 如果是第一次导入，先创建临时表写入表头+数据，否则跳过表头只写数据
                If Not hasHeader Then
                    ' 在当前工作簿创建临时隐藏工作表
                    Set tempWs = ThisWorkbook.Worksheets.Add
                    tempWs.Visible = xlSheetVeryHidden
                    srcData.Copy tempWs.Range("A1")
                    Set tbl = tempWs.ListObjects.Add(xlSrcRange, tempWs.UsedRange, , xlYes)
                    tbl.Name = "合并数据源"
                    ' 将临时表加载到Data Model
                    ThisWorkbook.Model.Add tbl
                    hasHeader = True
                Else
                    ' 跳过表头，复制数据到临时表末尾
                    srcData.Offset(1, 0).Copy tempWs.Cells(tbl.ListRows.Count + 2, 1)
                    ' 刷新Data Model中的表
                    tbl.Refresh
                End If
            End If
        Next ws
        
        wbSource.Close SaveChanges:=False
    Next i
    
    ' 可选：取消下方注释即可自动删除临时工作表，数据已保存在Data Model中
    ' tempWs.Delete
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "数据导入完成，共导入" & tbl.ListRows.Count - 1 & "条有效数据到Data Model", vbInformation
End Sub

使用方法 #

• 打开需要导入数据的目标工作簿，按Alt+F11打开VBA编辑器
• 在左侧工程资源管理器中右键点击当前工作簿名称，选择「插入」→「模块」
• 将上述代码粘贴到弹出的模块编辑窗口中
• 按F5运行代码，在弹出的文件选择框中选中所有需要导入的源工作簿，点击「确定」即可

自定义调整说明 #

• 如果只需要导入指定名称的工作表，可以在遍历工作表的循环中添加判断：比如If ws.Name = "需要导入的表名" Then再执行后续导入逻辑
• 如果不需要保留临时工作表，可以取消代码中删除临时工作表行的注释，运行后临时表会自动删除，不会影响Data Model中的已导入数据

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