快速合并多个Excel文件的实用方法

在日常办公中，经常需要将多个Excel文件的数据整合到一个工作簿中。由于软件版本限制，某些新功能无法使用，网络上的工具也未必适用，因此通过VBA自行实现一键合并成为高效解决方案。

操作步骤说明

• 将所有待合并的Excel文件统一存放至同一个文件夹中，建议各文件结构保持一致以确保数据对齐。
• 打开目标工作簿，进入VBA编辑器，将下方提供的完整代码复制并粘贴到模块中。
• 在Excel界面中插入一个按钮，并将其关联到宏 MergeExcelFilesSimple。
• 点击该按钮后，程序会弹出文件夹选择窗口，用户需选定存放Excel文件的目录。
• 根据提示选择是否保留首个文件的表头信息。
• 系统开始自动读取每个文件的第一个工作表内容，并逐个追加至主工作表中。
• 等待处理完成，最终结果将在当前工作簿生成，且原有格式得以保留。

此方法尤其适用于大批量文件的合并任务，不仅能显著提升效率，还能有效避免手动复制粘贴过程中可能出现的人为错误。

VBA核心代码实现

Sub MergeExcelFilesSimple()
Dim folderPath As String
Dim fileName As String
Dim wb As Workbook, masterWb As Workbook
Dim ws As Worksheet, masterWs As Worksheet
Dim lastRow As Long, sourceLastRow As Long
Dim includeHeaders As Boolean
Dim firstFile As Boolean
Dim fileCount As Long, totalRows As Long
Dim fso As Object

On Error GoTo ErrorHandlerSimple

' 获取文件夹路径
folderPath = SelectFolderDialog()
If folderPath = "" Then Exit Sub

' 检查文件夹
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(folderPath) Then
    MsgBox "文件夹不存在: " & folderPath, vbExclamation
    Exit Sub
End If

' 用户选择
includeHeaders = MsgBox("是否包含每个文件的表头？" & vbCrLf & _
                      "点击【是】包含所有表头" & vbCrLf & _
                      "点击【否】只保留第一个文件的表头", _
                      vbYesNo + vbQuestion, "合并选项") = vbYes

' 创建主工作簿
Set masterWb = Workbooks.Add
Set masterWs = masterWb.Worksheets(1)
masterWs.Name = "合并数据"

' 初始化
firstFile = True
fileCount = 0
totalRows = 0

' 设置应用程序
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

' 显示进度
Application.StatusBar = "正在搜索Excel文件..."

' 获取文件列表
Dim fileCollection As New Collection
fileName = Dir(folderPath & "*.xlsx")
While fileName <> ""
    fileCollection.Add fileName
    fileName = Dir()
Wend

fileName = Dir(folderPath & "*.xls")
While fileName <> ""
    fileCollection.Add fileName
    fileName = Dir()
Wend

fileName = Dir(folderPath & "*.xlsm")
While fileName <> ""
    fileCollection.Add fileName
    fileName = Dir()
Wend

If fileCollection.Count = 0 Then
    MsgBox "未找到Excel文件！", vbExclamation
    GoTo CleanUp
End If

' 处理文件
Dim i As Long
For i = 1 To fileCollection.Count
    fileName = fileCollection(i)
    fileCount = fileCount + 1
    
    Application.StatusBar = "正在处理文件 " & fileCount & "/" & fileCollection.Count & ": " & fileName
    DoEvents
    
    ' 打开文件
    Set wb = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
    
    ' 处理每个工作表
    For Each ws In wb.Worksheets
        sourceLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        If sourceLastRow > 0 Then ' 有数据
            lastRow = masterWs.Cells(masterWs.Rows.Count, 1).End(xlUp).Row
            If lastRow = 1 And masterWs.Cells(1, 1).Value = "" Then lastRow = 0
            
            If firstFile Then
                ' 第一个文件：完整复制
                ws.UsedRange.Copy
                masterWs.Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                firstFile = False
                totalRows = totalRows + sourceLastRow
            Else
                If includeHeaders Then
                    ' 包含表头
                    ws.UsedRange.Copy
                    masterWs.Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                    totalRows = totalRows + sourceLastRow
                Else
                    ' 不包含表头（从第2行开始）
                    If sourceLastRow > 1 Then
                        ws.Range("A2", ws.Cells(sourceLastRow, ws.UsedRange.Columns.Count)).Copy
                        masterWs.Cells(lastRow + 1, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                        totalRows = totalRows + (sourceLastRow - 1)
                    End If
                End If
            End If
            
            Application.CutCopyMode = False
        End If
    Next ws
    
    ' 关闭文件
    wb.Close SaveChanges:=False
Next i

CleanUp:
’ 恢复应用程序状态
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False

' 格式化结果
If totalRows > 0 Then
    With masterWs
        .UsedRange.Columns.AutoFit
        .Cells(1, 1).Select
        
        ' 添加边框
        If .UsedRange.Borders.LineStyle = xlNone Then
            .UsedRange.Borders.LineStyle = xlContinuous
            .UsedRange.Borders.Weight = xlThin
        End If
        
        ' 添加筛选
        .Rows(1).AutoFilter
        
        MsgBox "合并完成！" & vbCrLf & _
               "处理文件数: " & fileCount & vbCrLf & _
               "合并总行数: " & totalRows, vbInformation
    End With
Else
    MsgBox "未合并到任何数据！", vbExclamation
    masterWb.Close SaveChanges:=False
End If

Set fso = Nothing
Exit Sub

ErrorHandlerSimple:
’ 统一异常处理机制
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.StatusBar = False

End Sub

’ 调用系统原生文件夹选择对话框（稳定性高）
Function SelectFolderDialog() As String
Dim shell As Object
Dim folder As Object

MsgBox "错误: " & Err.Description & vbCrLf & _
       "文件: " & fileName, vbCritical

If Not wb Is Nothing Then
    wb.Close SaveChanges:=False
End If

Set fso = Nothing

补充说明

本方案仅处理各文件中的第一个工作表内容，适合结构统一的数据汇总场景。使用者只需具备基础的Excel操作经验即可顺利执行。整个过程无需安装额外插件，安全可靠，值得尝试。

On Error Resume Next

' 方法1：使用Shell.Application（最可靠）
Set shell = CreateObject("Shell.Application")
Set folder = shell.BrowseForFolder(0, "请选择包含Excel文件的文件夹", 0, 0)

If Not folder Is Nothing Then
    SelectFolderDialog = folder.Self.Path
    If Right(SelectFolderDialog, 1) <> "\" Then
        SelectFolderDialog = SelectFolderDialog & "\"
    End If
Else
    ' 方法2：回退到输入框
    SelectFolderDialog = InputBox("请输入文件夹路径:", "选择文件夹", ThisWorkbook.Path)
    If SelectFolderDialog <> "" Then
        If Right(SelectFolderDialog, 1) <> "\" Then
            SelectFolderDialog = SelectFolderDialog & "\"
        End If
    End If
End If

On Error GoTo 0