Excel多文件数据合并工具（VBA实现）

📌 工具功能概览

• 一键合并多个Excel文件：支持.xls, .xlsx, .xlsm格式
• 智能列匹配：自动识别源文件与汇总表列对应关系，只导入汇总表中有的列。
• 空行自动过滤：跳过源文件中第2列为空的数据行（部分源数据第一列是序号，有可能为空，第2列一般不应为空，此处可根据需求修改）
• 特殊字段处理：修正长字符串变科学计数法问题
• 双合并模式：
  • 覆盖模式：清空现有数据重新合并
  • 追加模式：保留历史数据追加新内容
• 数据溯源：自动添加来源文件列记录原始文件名
• 默认路径：默认打开当前工作簿所在目录

🛠️ 使用说明

准备阶段

1. 新建Excel工作簿，创建名为汇总表的工作表，默认采用Sheet1为汇总主页面
2. 在汇总表第一行设置需要的列标题（如：客户名称、客户地址等）

操作步骤

1. 按 Alt+F11 打开VBA编辑器
2. 插入新模块并粘贴提供的代码
3. 按 Alt+F8 运行MergeExcelFiles宏
4. 选择合并模式：
   • ![覆盖模式]选择是清空现有数据重新合并
   • ![追加模式]选择否保留现有数据追加新内容
5. 选择要合并的Excel文件（支持多选）
6. 如果提示该工程中的宏被禁止。需要在EXCEL的信任中心启用所有宏。

⚠️ 使用注意事项

1. 列名一致性：源文件列名需与汇总表列名完全一致
2. 文件规范：

• 源文件数据从第2行开始
• 第1行为列标题行
• 默认只汇总第一个Sheet
• 支持最大数据量：104万行

🌟 技术亮点

' 智能列匹配核心代码
Set colMapping = CreateObject("Scripting.Dictionary")
For Each headerCell In srcSheet.Range("A1").CurrentRegion.Rows(1)
    If headerMap.Exists(Trim(headerCell.Value)) Then
        colMapping(headerMap(srcHeader)) = headerCell.Column
    End If
Next


📥 以下为完整代码

Attribute VB_Name = "自动合并EXCEL"
Option Explicit

Sub MergeExcelFiles()
    '========== 参数设置 ==========
    Const SUMMARY_SHEET As String = "Sheet1"
    Const DATA_START_ROW As Long = 2
    Const SOURCE_COLUMN As String = "来源文件"
    
    '========== 变量声明 ==========
    Dim wsSummary As Worksheet
    Dim fd As Office.FileDialog
    Dim selectedFiles As Variant
    Dim srcBook As Workbook
    Dim srcSheet As Worksheet
    Dim headerMap As Object
    Dim headerCell As Range
    Dim colKey As Variant
    Dim i As Long, j As Long, fileCount As Long
    Dim lastRow As Long, summaryRow As Long
    Dim sourceCol As Long
    
    '========== 初始化设置 ==========
    Set wsSummary = ThisWorkbook.Worksheets(SUMMARY_SHEET)
    If wsSummary.Cells(1, wsSummary.Columns.Count).Value <> SOURCE_COLUMN Then
        sourceCol = wsSummary.Cells(1, wsSummary.Columns.Count).End(xlToLeft).Column + 1
    End If
    If wsSummary.Cells(1, sourceCol).Value <> SOURCE_COLUMN Then
       wsSummary.Cells(1, sourceCol).Value = SOURCE_COLUMN
    End If
    ' 增加合并模式选择
    Dim mergeMode As VbMsgBoxResult
    mergeMode = MsgBox("请选择合并模式：" & vbCrLf & _
                     "是(Y) - 清空并全部重新合并" & vbCrLf & _
                     "否(N) - 追加到现有数据末尾", _
                     vbYesNoCancel + vbQuestion, "合并选项")
    
    If mergeMode = vbCancel Then Exit Sub
    If mergeMode = vbYes Then
        If wsSummary.Range("A2").Value <> "" Then
            wsSummary.Range("A2").CurrentRegion.Offset(1).ClearContents
        End If
        summaryRow = DATA_START_ROW
    Else
        summaryRow = wsSummary.Cells(wsSummary.Rows.Count, 1).End(xlUp).Row + 1
    End If
    
    ' 构建标题映射字典（仅包含需要的字段）
    Set headerMap = CreateObject("Scripting.Dictionary")
    With wsSummary.Range("A1").CurrentRegion.Rows(1)
        For Each headerCell In .Cells
            headerMap(Trim(headerCell.Value)) = headerCell.Column
        Next
    End With
    
    '========== 文件选择 ==========
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    With fd
        .Title = "选择要合并的Excel文件"
        .AllowMultiSelect = True
        .Filters.Add "Excel文件", "*.xls; *.xlsx; *.xlsm"
        .InitialFileName = ThisWorkbook.Path & "\"
        If .Show <> -1 Then Exit Sub
        
        fileCount = .SelectedItems.Count
        ReDim selectedFiles(1 To fileCount)
        For i = 1 To fileCount
            selectedFiles(i) = CStr(.SelectedItems(i))
        Next
    End With
   '========== 数据处理 ==========
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    For i = 1 To fileCount
        If Dir(selectedFiles(i)) = "" Then GoTo NextFile
        
        Set srcBook = Workbooks.Open(selectedFiles(i))
        Set srcSheet = srcBook.Sheets(1)
        
        ' 建立精确列映射（仅匹配汇总表需要的列）
        Dim colMapping As Object
        Set colMapping = CreateObject("Scripting.Dictionary")
        
        With srcSheet.Range("A1").CurrentRegion.Rows(1)
            For Each headerCell In .Cells
                Dim srcHeader As String
                srcHeader = Trim(CStr(headerCell.Value))
                If headerMap.Exists(srcHeader) Then
                    ' 键：汇总表列号 / 值：源文件列号
                    colMapping(headerMap(srcHeader)) = headerCell.Column
                End If
            Next
        End With
        
        lastRow = srcSheet.Cells(srcSheet.Rows.Count, 1).End(xlUp).Row
        
        If lastRow >= DATA_START_ROW And colMapping.Count > 0 Then
            For j = DATA_START_ROW To lastRow
                Dim isEmptyRow As Boolean
                isEmptyRow = True
                For Each colKey In colMapping.Keys
                '跳过源文件中第2列为空的数据行
                    If Trim(srcSheet.Cells(2, colMapping(colKey)).Value) <> "" Then
                        isEmptyRow = False
                        Exit For
                    End If
                    ' 严格按汇总表结构写入数据
                   Next
                   If Not isEmptyRow Then
                    For Each colKey In colMapping.Keys
                    With wsSummary.Cells(summaryRow, colKey)
                        .Value = Trim(srcSheet.Cells(j, colMapping(colKey)).Value)
                        ' 纳税人识别号特殊处理
                            .NumberFormat = "@"
                            .Value = "'" & CStr(srcSheet.Cells(j, colMapping(colKey)).Text)
                    End With
                Next colKey
                wsSummary.Cells(summaryRow, sourceCol).Value = fso.GetFileName(selectedFiles(i))
                summaryRow = summaryRow + 1
                End If
            Next j
        End If
        
        srcBook.Close False
NextFile:
    Next i
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "合并完成！" & vbCrLf & _
           "处理文件数：" & fileCount & vbCrLf & _
           "新增记录数：" & summaryRow - DATA_START_ROW, _
           vbInformation, "操作报告"
End Sub