一键合并多个Excel文件

一键合并多个Excel文件

最近工作中，需要合并多个Excel文件，由于版本原因，一些新的功能无法使用，搜了许久也没有找到合适的，只好自己动手丰衣足食。

操作说明

将需要合并的Excel文件放到同一个文件夹里，这些文件的格式最好是统一的，然后打开多文件合并工具，点击“一键合并多文件”按钮，按照提示操作即可完成文件合并，此版本仅支持合并文件第一个工作表的内容。文件越多效率越高，同时可以避免一些手工复制粘贴可能出现的认为错误。

1. 复制完整代码到VBA模块
2. 在开放工具中插入按钮并指定宏MergeExcelFilesSimple
3. 把需合并的文件放到同一文件夹
4. 点击合并按钮
5. 选择文件夹
6. 选择是否包含表头
7. 等待合并完成

就可以在保留原表格式的前提下合并多个文件了。

多文件合并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

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

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

Set fso = Nothing

End Sub

’ 文件夹选择对话框（最可靠）
Function SelectFolderDialog() As String
Dim shell As Object
Dim folder As Object

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

End Function

只需要一点Excel使用经验，就可以轻松的实现上述功能，有兴趣的不妨试试。