ARTICLE · 1074560
Excel VBA神器~一键百万级数据不卡顿,列名自动匹配-高速合并自动增加文件名
Excel VBA神器~一键百万级数据不卡顿,列名自动匹配-高速合并自动增加文件名 日常汇总数据经常遇到：每个Excel文件里面有多个工作表，还要跳过N行表头，不同文件的列顺序还不一样，复制粘贴卡到崩溃。 普通VBA用Copy方法，数据量大直接卡死。数组版，全程内存运算，不使用单元格复制，速度提升几十倍。 ✅ 核心功能清单 1. 多选Excel文件，读取选中文件内全部工作表 2. 可自定义【表头行数】，比如表头占2行，就跳过前2行，取下面数据 3. 列名映射：自动根据列标题匹配字段，不管源表列顺序是否一致 4. 自动新增一列：【来源文件名】，每条数据标记来自哪个文件 5. 数组内存读写，不使用Copy，百万行大数据稳定运行 6. 自动去重表头，汇总表只保留1次标题 7. 错误捕获：文件损坏、空工作表自动跳过，不会中断整个汇总任务 使用说明：新建一个空白汇总Excel，打开VBA编辑器，粘贴代码，运行宏【MultiFile_MultiSheet_MergeByTitle】 vba Option Explicit Sub MultiFile_MultiSheet_MergeByTitle() '数组版：多选文件，合并每个文件内所有工作表，按列名匹配，自定义表头行数，增加来源文件名 Dim fd As FileDialog Dim selectedItem As Variant Dim srcWb As Workbook Dim srcWs As Worksheet Dim targetWs As Worksheet Dim headerRowCnt As Long '表头行数 Dim srcArr As Variant Dim titleArr As Variant '源表标题数组 Dim targetTitleArr As Variant '汇总表标题数组 Dim mapDict As Object '列名映射字典 key:源列名,value:汇总表第几列 Dim i As Long, j As Long, r As Long, c As Long Dim lastR As Long, lastC As Long Dim newRow As Long Dim fileName As String Dim outputArr As Variant '输出数组，一次性写入汇总表 '====================【可修改参数区】==================== headerRowCnt = 1 '👉这里修改表头行数，表头占2行就写2 Set targetWs = ThisWorkbook.Sheets("汇总") '👉存放结果的工作表名称 '======================================================== Set mapDict = CreateObject("Scripting.Dictionary") mapDict.CompareMode = vbTextCompare '不区分大小写匹配列名 '清空汇总表原有内容 targetWs.Cells.Clear newRow = headerRowCnt + 1 '数据开始写入行 '选择要合并的Excel文件 Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "请选择需要合并的Excel文件（可多选）" .Filters.Clear .Filters.Add "Excel文件", "*.xls;*.xlsx;*.xlsm" .AllowMultiSelect = True If .Show <> -1 Then MsgBox "未选择任何文件，退出", vbInformation Set fd = Nothing Exit Sub End If selectedItem = .SelectedItems End With Set fd = Nothing Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False '循环每一个选中文件 For i = LBound(selectedItem) To UBound(selectedItem) fileName = selectedItem(i) On Error Resume Next Set srcWb = Workbooks.Open(Filename:=fileName, ReadOnly:=True) On Error GoTo 0 If srcWb Is Nothing Then MsgBox "文件打开失败：" & fileName, vbExclamation GoTo NextFile End If '循环当前文件里【所有工作表】 For Each srcWs In srcWb.Worksheets lastR = srcWs.Cells(srcWs.Rows.Count, 1).End(xlUp).Row lastC = srcWs.Cells(headerRowCnt, srcWs.Columns.Count).End(xlToLeft).Column '判断工作表是否有数据 If lastR <= headerRowCnt Or lastC < 1 Then GoTo NextSheet End If '读取表头行 titleArr = srcWs.Range(srcWs.Cells(headerRowCnt, 1), srcWs.Cells(headerRowCnt, lastC)).Value '第一次运行：初始化汇总表标题，构建映射字典 If mapDict.Count = 0 Then ReDim targetTitleArr(1 To UBound(titleArr, 2) + 1) '写入原有列名 For c = 1 To UBound(titleArr, 2) targetTitleArr(c) = titleArr(1, c) mapDict(titleArr(1, c)) = c Next c '新增【来源文件名】字段 targetTitleArr(UBound(targetTitleArr)) = "来源文件名" mapDict("来源文件名") = UBound(targetTitleArr) '一次性写入汇总表头 targetWs.Range(targetWs.Cells(headerRowCnt, 1), targetWs.Cells(headerRowCnt, UBound(targetTitleArr))).Value = targetTitleArr End If '读取源表全部数据到数组（跳过前面表头行） srcArr = srcWs.Range(srcWs.Cells(headerRowCnt + 1, 1), srcWs.Cells(lastR, lastC)).Value '遍历源表每一行数据 For r = 1 To UBound(srcArr, 1) '定义单行输出数组，长度=汇总表总列数 ReDim outputArr(1 To mapDict.Count) '循环源表每一列，按列名匹配写入对应位置 For c = 1 To UBound(titleArr, 2) If mapDict.Exists(titleArr(1, c)) Then outputArr(mapDict(titleArr(1, c))) = srcArr(r, c) End If Next c '填充来源文件名 outputArr(mapDict("来源文件名")) = srcWb.Name & "|" & srcWs.Name '把单行数组写入汇总表 targetWs.Cells(newRow, 1).Resize(1, UBound(outputArr)).Value = outputArr newRow = newRow + 1 Next r NextSheet: Next srcWs srcWb.Close SaveChanges:=False Set srcWb = Nothing NextFile: Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True MsgBox "合并完成！" & vbCrLf & "一共导入：" & newRow - headerRowCnt - 1 & " 行数据", vbInformation End Sub 🔧 参数修改说明（重点看这里） 1. headerRowCnt = 1 代表表头占1行。如果你的文件表头是2行，改成 headerRowCnt = 2 ，程序自动跳过前2行，从第3行读取数据。 2. Set targetWs = ThisWorkbook.Sheets("汇总") 记得在你的汇总工作簿新建工作表，命名叫【汇总】，输出结果全部放在这个表。 3. 列名匹配逻辑 程序按照表头文字匹配，源文件工作表列顺序不一样也没关系。 👉举例：A文件列顺序：姓名｜电话｜地址；B文件：电话｜姓名｜地址。合并后自动对齐字段。 ⚠️注意：列名文字必须完全一致（大小写不敏感，空格会影响匹配，空格不一致识别为不同字段） 4. 来源文件名规则 自动新增【来源文件名】列，格式： 文件名.xlsx|工作表名 ，一眼知道这条数据来自哪个文件哪个工作表。 ⚠️ 避坑提醒（高频踩坑） 1. 大数据优势：全程数组，没有range.copy，上万行、几十万行数据不会卡顿。 2. 只读打开外部文件，不会修改源文件，源文件不会被改动。 3. 如果部分工作表没有数据，代码自动跳过，不会报错终止合并。 4. 列名前后有空格会匹配失败！例如 姓名 和 姓名 视为两个字段。 5. 支持格式：xlsx、xlsm、xls。不支持csv，如果需要合并csv可以告诉我扩展版本。 6. 运行前关闭其他打开的Excel，减少冲突。 ✨ 专业定制vba数据分析，解决工作困扰，自动化办公效率翻倍。 可以关注私信留言提问 一键导入外部Excel！VBA文件选择器，自动提取数据到当前表 Excel VBA｜多个文件，批量合并数据导入到当前表 VBA一键按条件自动提取数据（文员、生产统计专用） VBA一键导出！把当前表的数据，自动写入指定工作簿，告别复制粘贴 别再只用RANK！Excel多条件排名，业绩产量排序直接套用