如何用Excel VBA宏自动批量导入同文件夹下多文件的单个工作表

下面提供两种实现方案，可根据使用场景选择：

方案1：手动多选文件批量导入 #

支持在弹出的文件选择框中一次选中多个Excel文件，批量完成导入操作：

Sub 批量多选导入工作表()
    Dim selectFiles As Variant, wb As Workbook, sh As Worksheet
    Dim i As Long
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 弹出多选文件对话框
    selectFiles = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*", MultiSelect:=True)
    ' 未选中文件时直接退出
    If IsArray(selectFiles) = False Then
        MsgBox "未选中任何文件"
        GoTo 结束处理
    End If
    
    ' 循环处理所有选中的文件
    For i = LBound(selectFiles) To UBound(selectFiles)
        ' 跳过当前宏文件本身，避免重复导入
        If selectFiles(i) <> ThisWorkbook.FullName Then
            Set wb = Workbooks.Open(selectFiles(i))
            ' 取文件中第一个非空工作表导入
            For Each sh In wb.Sheets
                If Application.CountA(sh.Cells) > 0 Then
                    sh.Copy Before:=ThisWorkbook.Sheets(1)
                    ' 如需固定导入Sheet1，删除上面的循环，替换为下面这行代码即可
                    ' wb.Sheets("Sheet1").Copy Before:=ThisWorkbook.Sheets(1)
                    Exit For
                End If
            Next
            wb.Close SaveChanges:=False
        End If
    Next
    MsgBox "导入完成，共处理" & UBound(selectFiles) - LBound(selectFiles) + 1 & "个文件"
    
结束处理:
    Application.ScreenUpdating = True
End Sub

方案2：自动识别同文件夹所有文件导入 #

无需手动选择文件，自动读取当前宏文件所在目录下所有符合格式的Excel文件，适合文件数量较多的场景：

Sub 自动批量导入同目录工作表()
    Dim folderPath As String, fileName As String, wb As Workbook, sh As Worksheet
    Dim importCount As Long
    ' 关闭屏幕更新提升运行速度
    Application.ScreenUpdating = False
    
    ' 获取当前宏文件所在文件夹路径
    folderPath = ThisWorkbook.Path & "\"
    importCount = 0
    
    ' 遍历文件夹下所有Excel格式文件
    fileName = Dir(folderPath & "*.xl*")
    Do While fileName <> ""
        ' 跳过当前宏文件本身
        If fileName <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(folderPath & fileName)
            ' 取文件中第一个非空工作表导入
            For Each sh In wb.Sheets
                If Application.CountA(sh.Cells) > 0 Then
                    sh.Copy Before:=ThisWorkbook.Sheets(1)
                    ' 如需固定导入Sheet1，删除上面的循环，替换为下面这行代码即可
                    ' wb.Sheets("Sheet1").Copy Before:=ThisWorkbook.Sheets(1)
                    Exit For
                End If
            Next
            wb.Close SaveChanges:=False
            importCount = importCount + 1
        End If
        fileName = Dir
    Loop
    
    If importCount = 0 Then
        MsgBox "当前文件夹下未找到可导入的Excel文件"
    Else
        MsgBox "导入完成，共处理" & importCount & "个文件"
    End If
    
    Application.ScreenUpdating = True
End Sub

代码说明 #

• 两段代码都兼容所有常见Excel格式（.xlsx/.xls/.xlsm等），不受文件数量限制
• 导入的工作表默认放在宏工作簿的最前面，如需调整到最后，可将Before:=ThisWorkbook.Sheets(1)修改为After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
• 运行过程中自动跳过已打开的文件，不会出现冲突报错

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