VBA一键对比两个Excel文件|自动识别相同-差异数据,不同单元格填充颜色
- 2026-11-11 06:03:32
VBA一键对比两个Excel文件|自动识别相同-差异数据,不同单元格填充颜色功能简介 1. 弹出文件选择框，依次选择【文件A】【文件B】进行对比 2. 支持按关键字段匹配两行数据（代码内可修改匹配列） 3. 结果写入当前工作簿新建工作表： ✅ 完全一致的数据 ❗存在差异的数据，不一样的单元格自动填充底色 4. 数组方案，大数据量速度快，不使用Copy粘贴 5. 自动记录来源，方便溯源 使用前提：两个待对比文件，结构尽量一致，拥有唯一匹配关键字段（如编号、工号） 完整VBA代码 vba Sub CompareTwoExcelFile() Dim fd As FileDialog Dim strFile1 As String, strFile2 As String Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet, wsResult As Worksheet Dim arr1 As Variant, arr2 As Variant Dim dict As Object Dim i As Long, j As Long, r As Long, c As Long Dim keyText As String Dim rowData As Variant Dim diffCols As Collection '====================配置区【公众号读者重点修改这里】==================== Const MatchCol As Long = 1 '匹配关键字所在列，A列=1，B列=2（比如工号放在A列） Const HeaderRow As Long = 1 '表头行数 Const DiffColor As Long = RGB(255, 204, 204) '差异单元格填充浅红色 '======================================================================== Set dict = CreateObject("Scripting.Dictionary") dict.CompareMode = vbTextCompare '不区分大小写 '====弹窗选择第1个文件==== Set fd = Application.FileDialog(msoFileDialogFilePicker) With fd .Title = "请选择【第一个对比文件】" .Filters.Clear .Filters.Add "Excel文件", "*.xls;*.xlsx;*.xlsm" If .Show <> -1 Then MsgBox "未选择第一个文件，退出！", vbExclamation Set fd = Nothing Exit Sub End If strFile1 = .SelectedItems(1) End With '====弹窗选择第2个文件==== With fd .Title = "请选择【第二个对比文件】" If .Show <> -1 Then MsgBox "未选择第二个文件，退出！", vbExclamation Set fd = Nothing Exit Sub End If strFile2 = .SelectedItems(1) End With Set fd = Nothing Application.ScreenUpdating = False Application.DisplayAlerts = False '打开两个对比文件 Set wb1 = Workbooks.Open(strFile1, ReadOnly:=True) Set ws1 = wb1.Sheets(1) '默认取第一个工作表，可自行修改 Set wb2 = Workbooks.Open(strFile2, ReadOnly:=True) Set ws2 = wb2.Sheets(1) '读取数组 arr1 = ws1.UsedRange.Value arr2 = ws2.UsedRange.Value '把文件2数据装入字典，关键字=匹配字段 For i = HeaderRow + 1 To UBound(arr2) keyText = Trim(CStr(arr2(i, MatchCol))) If keyText <> "" Then If Not dict.Exists(keyText) Then dict(keyText) = i '存储行号 End If End If Next i '新建结果表 On Error Resume Next Set wsResult = ThisWorkbook.Sheets("对比结果") On Error GoTo 0 If Not wsResult Is Nothing Then wsResult.Delete Set wsResult = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsResult.Name = "对比结果" '写入表头 wsResult.Range("A1").Value = "匹配关键字" wsResult.Range("B1").Value = "对比状态" wsResult.Range("C1").Value = "文件1来源" wsResult.Range("D1").Value = "文件2来源" '读取原始表头写入右侧 For c = 1 To UBound(arr1, 2) wsResult.Cells(1, 4 + c).Value = arr1(HeaderRow, c) Next c r = 2 '结果表起始行 '循环文件1所有数据 For i = HeaderRow + 1 To UBound(arr1) keyText = Trim(CStr(arr1(i, MatchCol))) If keyText <> "" Then If dict.Exists(keyText) Then '找到匹配行 j = dict(keyText) Set diffCols = New Collection '逐列对比 For c = 1 To UBound(arr1, 2) If Trim(CStr(arr1(i, c))) <> Trim(CStr(arr2(j, c))) Then diffCols.Add c End If Next c If diffCols.Count = 0 Then '✅完全一致 wsResult.Cells(r, 1).Value = keyText wsResult.Cells(r, 2).Value = "✅数据完全一致" wsResult.Cells(r, 3).Value = strFile1 wsResult.Cells(r, 4).Value = strFile2 '写入原始行数据 For c = 1 To UBound(arr1, 2) wsResult.Cells(r, 4 + c).Value = arr1(i, c) Next c Else '❗存在差异 wsResult.Cells(r, 1).Value = keyText wsResult.Cells(r, 2).Value = "❗存在差异" wsResult.Cells(r, 3).Value = strFile1 wsResult.Cells(r, 4).Value = strFile2 '写入数据+标色 For c = 1 To UBound(arr1, 2) wsResult.Cells(r, 4 + c).Value = arr1(i, c) Next c '差异单元格填充颜色 For Each c In diffCols wsResult.Cells(r, 4 + c).Interior.Color = DiffColor Next c End If r = r + 1 Else '仅文件1存在，文件2无这条记录 wsResult.Cells(r, 1).Value = keyText wsResult.Cells(r, 2).Value = "⚠️仅文件1有此条，文件2缺失" wsResult.Cells(r, 3).Value = strFile1 wsResult.Cells(r, 4).Value = "无" For c = 1 To UBound(arr1, 2) wsResult.Cells(r, 4 + c).Value = arr1(i, c) Next c r = r + 1 End If End If Next i '遍历字典，找出文件2独有（文件1不存在） For Each keyText In dict.Keys Dim isExist As Boolean isExist = False For i = HeaderRow + 1 To UBound(arr1) If Trim(CStr(arr1(i, MatchCol))) = keyText Then isExist = True Exit For End If Next i If Not isExist Then j = dict(keyText) wsResult.Cells(r, 1).Value = keyText wsResult.Cells(r, 2).Value = "⚠️仅文件2有此条，文件1缺失" wsResult.Cells(r, 3).Value = "无" wsResult.Cells(r, 4).Value = strFile2 For c = 1 To UBound(arr2, 2) wsResult.Cells(r, 4 + c).Value = arr2(j, c) Next c r = r + 1 End If Next keyText '关闭源文件，不保存 wb1.Close SaveChanges:=False wb2.Close SaveChanges:=False Application.ScreenUpdating = True Application.DisplayAlerts = True wsResult.Columns.AutoFit MsgBox "对比完成！结果已写入【对比结果】工作表" & vbCrLf & "差异单元格已标红底色", vbInformation End Sub 💡重点说明&避坑 1. 数组读取数据，大数据量也很快，没有使用Copy粘贴 2. 目前默认读取两个文件的第一个工作表；如果需要指定工作表名称，修改代码中 Set ws1 = wb1.Sheets(1) 改成 Sheets("Sheet名称") 3. 两个文件列数量不一致时：以文件1的列数为主进行对比 4. 只读方式打开源文件，不会修改你的原始数据，安全 5. 匹配逻辑：依靠【唯一关键字】匹配行，不适合无主键乱序表格 ✨扩展小修改（读者按需改） - 修改 DiffColor 可以更换差异底色：黄色 RGB(255,255,0) 、橙色 RGB(255,153,0) - 想要区分：文件1和文件2不一样的值分开两列展示，我可以给你升级版本 - 如果需要多字段联合匹配（比如部门+工号双条件匹配），也可以调整 之前分享过：批量合并多文件所有工作表、一键导出数据、多条件排名，需要合集的可以留言。 ✨✨✨专业定制VBA数据自动化处理解决方案欢迎交流。 Excel VBA神器～一键百万级数据不卡顿，列名自动匹配-高速合并自动增加文件名 VBA一键导出！把当前表的数据，自动写入指定工作簿，告别复制粘贴 Excel VBA｜多个文件，批量合并数据导入到当前表 VBA一键按条件自动提取数据（文员、生产统计专用） 一键导入外部Excel！VBA文件选择器，自动提取数据到当前表
本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。
