VBA代码修改求助：实现从多个选中的Excel文件批量提取数据

核心修改逻辑 #

• 开启文件选择框的多选权限，支持一次性选中多个目标xlsm文件
• 移除原有单次选择后的询问跳转逻辑，改为直接遍历所有选中的文件批量处理
• 增加取消选择的异常判断，避免无文件选中时程序报错
• 将屏幕刷新开关移到循环外部，提升批量处理效率
• 保留原有的值粘贴逻辑，不改动原文件数据

修改后完整代码 #

Sub 批量提取Sheet1数据到总表()
    Application.ScreenUpdating = False
    Dim flder As FileDialog
    Dim FileChosen As Integer
    Dim selectedFile As Variant
    Dim wkbSource As Workbook
    Dim wkbDest As Workbook
    Dim destLastRow As Long
    
    Set wkbDest = ThisWorkbook
    
    ' 初始化文件选择框
    Set flder = Application.FileDialog(msoFileDialogFilePicker)
    With flder
        .Title = "请选择需要提取数据的Excel文件（可多选）"
        .InitialFileName = "c:\"
        .InitialView = msoFileDialogViewSmallIcons
        .Filters.Clear
        .Filters.Add "Excel Files", "*.xlsm*"
        .AllowMultiSelect = True ' 核心修改：允许多选
    End With
    
    MsgBox "可按住Ctrl/Shift多选目标文件，选完后点击确定"
    FileChosen = flder.Show
    
    ' 判断用户是否点击了取消
    If FileChosen <> 1 Then
        MsgBox "未选中任何文件，程序退出"
        GoTo Cleanup
    End If
    
    ' 遍历所有选中的文件
    For Each selectedFile In flder.SelectedItems
        Set wkbSource = Workbooks.Open(selectedFile)
        
        ' 计算总表当前最后一行
        destLastRow = wkbDest.Sheets("Master").Cells(wkbDest.Sheets("Master").Rows.Count, "A").End(xlUp).Row + 1
        
        ' 粘贴值
        wkbSource.Sheets("Sheet1").UsedRange.Copy
        wkbDest.Sheets("Master").Cells(destLastRow, "A").PasteSpecial xlPasteValues
        
        Application.CutCopyMode = False
        wkbSource.Close savechanges:=False
    Next selectedFile
    
    MsgBox "批量提取完成，共处理" & flder.SelectedItems.Count & "个文件"

Cleanup:
    Application.ScreenUpdating = True
    Set flder = Nothing
    Set wkbSource = Nothing
    Set wkbDest = Nothing
End Sub

可选调整项 #

• 如果所有源文件的Sheet1都带有相同表头，不需要重复粘贴，可以在粘贴代码处加判断：如果是第一个文件就保留表头，后续文件从UsedRange的第二行开始复制即可
• 如果需要支持xlsx、xls等其他格式，直接修改Filters里的后缀规则就行，比如改成"*.xlsm;*.xlsx;*.xls"

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