◎欢迎参与讨论，请在这里发表您的看法、交流您的观点。
用对AI，效率快的不得了！！！产品清单比较宏代码
摘要：
两份排序杂乱无章的产品清单，使用下面的宏代码，16秒搞定！功能特点:...
总字数：44018两份排序杂乱无章的产品清单，使用下面的宏代码，16秒搞定！
功能特点:
✅ 完整功能：支持.xls/.xlsx/.xlsm/.xlsb全格式对比
✅ 智能对比：以编码为主键，双向查找对比
✅ 差异标记：红色/绿色标注不同数据，橙色标注独有编码
✅ 注释系统：详细说明差异位置和类型
✅ 层次处理：自动识别BOM层级关系
✅ 性能优化：字典索引快速查找，跳过空行
✅ 结果统计：完整对比报告和用时统计
制造业、供应链管理或物料清单管理需要频繁对比BOM文件，能大幅提高工作效率。
使用方法:
以第2行的物料编码，做两个文件的数据对比。
打开第一个文件，按Alt+F11打开宏编辑界面，插入-模块，复制下面的宏代码，
再回到第一个文件，按Alt+F8，点执行，打开要第二个文件即可对比完成。
Sub CompareBOMFilesWithComments()
Dim wbA As Workbook, wbB As Workbook
Dim wsA As Worksheet, wsB As Worksheet
Dim lastRowA As Long, lastRowB As Long
Dim dict As Object
Dim i As Long, j As Long
Dim keyA As String, keyB As String
Dim foundRow As Long
Dim startTime As Double
Dim hasDiff As Boolean
Dim diffDetails As String
startTime = Timer
On Error GoTo ErrorHandler
Set dict = CreateObject("Scripting.Dictionary")
Set wbA = ThisWorkbook
Set wsA = wbA.Sheets(1)
' 获取B文件，支持所有Excel格式
Dim fileFilter As String
fileFilter = "Excel文件 (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb"
Dim filePathB As String
filePathB = Application.GetOpenFilename(fileFilter, , "请选择B文件（支持.xls/.xlsx/.xlsm/.xlsb格式）")
If filePathB = "False" Then Exit Sub
' 检测文件扩展名
Dim fileExt As String
fileExt = LCase(Right(filePathB, 4))
' 根据文件类型设置打开模式
Dim readOnlyMode As Boolean
Dim updateLinks As Boolean
readOnlyMode = True
updateLinks = False
' 特殊处理.xls文件
If fileExt = ".xls" Then
Set wbB = Workbooks.Open(filePathB, UpdateLinks:=updateLinks, ReadOnly:=readOnlyMode)
Else
Set wbB = Workbooks.Open(filePathB, UpdateLinks:=updateLinks, ReadOnly:=readOnlyMode)
End If
' 获取第一个工作表
On Error Resume Next
Set wsB = wbB.Sheets(1)
If wsB Is Nothing Then
MsgBox "无法访问B文件的第一个工作表，请检查文件格式。", vbExclamation
Exit Sub
End If
On Error GoTo ErrorHandler
' 获取数据范围
lastRowA = GetLastRow(wsA, 2)
lastRowB = GetLastRow(wsB, 2)
' 检查是否有数据
If lastRowA <= 1 Then
MsgBox "A文件没有数据或B列为空，请检查文件格式。", vbExclamation
GoTo Cleanup
End If
If lastRowB <= 1 Then
MsgBox "B文件没有数据或B列为空，请检查文件格式。", vbExclamation
GoTo Cleanup
End If
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
' 清除之前格式
ClearAllFormats wsA, lastRowA
ClearAllFormats wsB, lastRowB
' 添加对比结果列
Dim commentColA As Long, commentColB As Long
commentColA = GetLastColumn(wsA) + 1
commentColB = GetLastColumn(wsB) + 1
' 设置对比结果标题
SetupCommentHeaders wsA, commentColA, "A"
SetupCommentHeaders wsB, commentColB, "B"
' 创建B文件索引字典（只包含非空编码）
Dim rowCountB As Long
rowCountB = 0
For i = 2 To lastRowB
keyB = GetSafeCellValue(wsB.Cells(i, 2))
If keyB <> "" Then
If Not dict.Exists(keyB) Then
dict.Add keyB, i
rowCountB = rowCountB + 1
Else
' 重复编码标记
wsB.Cells(i, commentColB).Value = "编码重复"
wsB.Cells(i, commentColB).Interior.Color = RGB(255, 200, 200)
End If
End If
Next i
' 创建A文件索引字典用于双向查找（只包含非空编码）
Dim dictA As Object
Set dictA = CreateObject("Scripting.Dictionary")
For i = 2 To lastRowA
keyA = GetSafeCellValue(wsA.Cells(i, 2))
If keyA <> "" Then
If Not dictA.Exists(keyA) Then
dictA.Add keyA, i
Else
' 重复编码标记
wsA.Cells(i, commentColA).Value = "编码重复"
wsA.Cells(i, commentColA).Interior.Color = RGB(255, 200, 200)
End If
End If
Next i
Dim matchCount As Long, diffCount As Long
Dim uniqueCountA As Long, uniqueCountB As Long
matchCount = 0
diffCount = 0
uniqueCountA = 0
uniqueCountB = 0
' 对比A文件数据
For i = 2 To lastRowA
keyA = GetSafeCellValue(wsA.Cells(i, 2))
' 跳过空编码行
If keyA = "" Then
GoTo ContinueLoopCompareA
End If
If dict.Exists(keyA) Then
foundRow = dict(keyA)
matchCount = matchCount + 1
diffDetails = ""
hasDiff = False
' 对比C列：子件名称
If CompareCellsAdvanced(wsA.Cells(i, 3), wsB.Cells(foundRow, 3)) Then
wsA.Cells(i, 3).Interior.Color = RGB(255, 200, 200) ' 浅红色
wsB.Cells(foundRow, 3).Interior.Color = RGB(200, 255, 200) ' 浅绿色
diffDetails = diffDetails & "C"
hasDiff = True
End If
' 对比D列：单位用量
If CompareCellsAdvanced(wsA.Cells(i, 4), wsB.Cells(foundRow, 4)) Then
wsA.Cells(i, 4).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow, 4).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & IIf(diffDetails = "", "D", "/D")
hasDiff = True
End If
' 对比G列：位号
If CompareCellsAdvanced(wsA.Cells(i, 7), wsB.Cells(foundRow, 7)) Then
wsA.Cells(i, 7).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow, 7).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & IIf(diffDetails = "", "G", "/G")
hasDiff = True
End If
' 对比I列：注释信息
If CompareCellsAdvanced(wsA.Cells(i, 9), wsB.Cells(foundRow, 9)) Then
wsA.Cells(i, 9).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow, 9).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & IIf(diffDetails = "", "I", "/I")
hasDiff = True
End If
' 添加对比结果注释
If hasDiff Then
wsA.Cells(i, commentColA).Value = "B文件有差异[" & diffDetails & "]"
wsA.Cells(i, commentColA).Interior.Color = RGB(255, 240, 200) ' 浅橙色背景
wsB.Cells(foundRow, commentColB).Value = "A文件有差异[" & diffDetails & "]"
wsB.Cells(foundRow, commentColB).Interior.Color = RGB(220, 240, 255) ' 浅蓝色背景
diffCount = diffCount + 1
Else
wsA.Cells(i, commentColA).Value = "一致"
wsA.Cells(i, commentColA).Interior.Color = RGB(220, 255, 220) ' 浅绿色背景
wsB.Cells(foundRow, commentColB).Value = "一致"
wsB.Cells(foundRow, commentColB).Interior.Color = RGB(220, 255, 220)
End If
Else
' A文件独有编码
wsA.Cells(i, commentColA).Value = "B文件无此编码"
wsA.Cells(i, commentColA).Interior.Color = RGB(255, 220, 180) ' 橙色背景
' 标记A文件整行
MarkUniqueRow wsA, i, True
uniqueCountA = uniqueCountA + 1
End If
ContinueLoopCompareA:
Next i
' 标记B文件独有编码
For i = 2 To lastRowB
keyB = GetSafeCellValue(wsB.Cells(i, 2))
' 跳过空编码行
If keyB = "" Then
GoTo ContinueLoopCompareB
End If
If Not dictA.Exists(keyB) Then
' B文件独有编码
wsB.Cells(i, commentColB).Value = "A文件无此编码"
wsB.Cells(i, commentColB).Interior.Color = RGB(255, 240, 200) ' 浅橙色背景
' 标记B文件整行
MarkUniqueRow wsB, i, False
uniqueCountB = uniqueCountB + 1
End If
ContinueLoopCompareB:
Next i
' 处理层次关系
ProcessHierarchySafe wsA, lastRowA
ProcessHierarchySafe wsB, lastRowB
Cleanup:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
' 自动调整列宽（排除A列）
AutoFitColumnsExcludeA wsA, commentColA
AutoFitColumnsExcludeA wsB, commentColB
' 高亮显示差异编码
HighlightDifferencesWithComments wsA, lastRowA, commentColA
HighlightDifferencesWithComments wsB, lastRowB, commentColB
' 清理对象
Set dict = Nothing
Set dictA = Nothing
' 计算实际参与对比的行数
Dim actualRowsA As Long, actualRowsB As Long
actualRowsA = 0
actualRowsB = 0
For i = 2 To lastRowA
If GetSafeCellValue(wsA.Cells(i, 2)) <> "" Then actualRowsA = actualRowsA + 1
Next i
For i = 2 To lastRowB
If GetSafeCellValue(wsB.Cells(i, 2)) <> "" Then actualRowsB = actualRowsB + 1
Next i
' 显示结果统计
Dim msg As String
msg = "? 对比完成！" & vbCrLf & vbCrLf & _
"?? 文件统计：" & vbCrLf & _
"A文件总行数: " & (lastRowA - 1) & " 行" & vbCrLf & _
"A文件有效行: " & actualRowsA & " 行" & vbCrLf & _
"B文件总行数: " & (lastRowB - 1) & " 行" & vbCrLf & _
"B文件有效行: " & actualRowsB & " 行" & vbCrLf & vbCrLf & _
"?? 对比结果：" & vbCrLf & _
"编码匹配: " & matchCount & " 个" & vbCrLf & _
"数据差异: " & diffCount & " 处" & vbCrLf & _
"A文件独有: " & uniqueCountA & " 个" & vbCrLf & _
"B文件独有: " & uniqueCountB & " 个" & vbCrLf & vbCrLf & _
"?? 用时: " & Format(Timer - startTime, "0.00") & " 秒" & vbCrLf & vbCrLf & _
"?? 颜色说明：" & vbCrLf & _
"?? 红色: A文件与B文件不同的数据" & vbCrLf & _
"?? 绿色: B文件与A文件不同的数据" & vbCrLf & _
"?? 橙色: 编码不存在于另一文件" & vbCrLf & _
"?? 蓝色: 一致的数据"
MsgBox msg, vbInformation, "BOM文件对比完成"
' 激活A文件窗口
wbA.Activate
' 可选：询问是否保存B文件
Dim response As VbMsgBoxResult
response = MsgBox("B文件对比结果已标记。" & vbCrLf & _
"是否保存B文件？", vbQuestion + vbYesNo, "保存文件")
If response = vbYes Then
Dim savePath As String
Dim originalName As String
originalName = wbB.Name
savePath = wbB.Path & "\对比结果_" & Replace(originalName, "." & Split(originalName, ".")(UBound(Split(originalName, "."))), "") & ".xlsx"
' 保存文件
On Error Resume Next
wbB.SaveAs savePath, FileFormat:=xlOpenXMLWorkbook
If Err.Number = 0 Then
MsgBox "B文件已保存为：" & vbCrLf & savePath, vbInformation
End If
On Error GoTo 0
End If
' 关闭B文件
wbB.Close SaveChanges:=(response = vbYes)
Exit Sub
ErrorHandler:
MsgBox "错误 " & Err.Number & ": " & Err.Description & vbCrLf & _
"请检查文件格式和内容。", vbCritical, "对比失败"
GoTo Cleanup
End Sub
' 获取最后一行
Function GetLastRow(ws As Worksheet, col As Long) As Long
On Error Resume Next
' 从底部向上查找第一个非空单元格
GetLastRow = ws.Cells(ws.Rows.Count, col).End(xlUp).Row
If GetLastRow = 0 Then GetLastRow = 1
If GetLastRow = 1 And ws.Cells(1, col).Value = "" Then GetLastRow = 1
On Error GoTo 0
End Function
' 自动调整列宽（排除A列）
Sub AutoFitColumnsExcludeA(ws As Worksheet, lastCol As Long)
On Error Resume Next
' 为A列设置固定宽度
ws.Columns("A:A").ColumnWidth = 8
' 调整B列到最后一列的宽度
If lastCol > 2 Then
Dim colRange As Range
Set colRange = ws.Range(ws.Cells(1, 2), ws.Cells(1, lastCol)).EntireColumn
colRange.AutoFit
' 设置对比结果列宽度
ws.Columns(lastCol).ColumnWidth = 20
End If
' 自动调整行高
ws.Rows.AutoFit
On Error GoTo 0
End Sub
' 获取最后一列
Function GetLastColumn(ws As Worksheet) As Long
On Error Resume Next
GetLastColumn = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
If GetLastColumn = 0 Then GetLastColumn = 1
On Error GoTo 0
End Function
' 设置对比结果标题
Sub SetupCommentHeaders(ws As Worksheet, col As Long, fileType As String)
ws.Cells(1, col).Value = "对比结果(" & fileType & ")"
With ws.Cells(1, col)
.Font.Bold = True
.HorizontalAlignment = xlCenter
.Interior.Color = RGB(200, 200, 200)
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
End Sub
' 清除所有格式
Sub ClearAllFormats(ws As Worksheet, lastRow As Long)
If lastRow > 1 Then
' 清除数据区域的格式
Dim lastCol As Long
lastCol = GetLastColumn(ws)
If lastCol > 0 Then
With ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
.ClearFormats
.Font.Bold = False
.Font.Color = RGB(0, 0, 0)
.Interior.ColorIndex = xlNone
End With
End If
End If
End Sub
' 安全的获取单元格值
Function GetSafeCellValue(cell As Range) As String
On Error Resume Next
If IsError(cell.Value) Then
GetSafeCellValue = ""
ElseIf IsNull(cell.Value) Then
GetSafeCellValue = ""
ElseIf cell.Value = "" Then
GetSafeCellValue = ""
Else
GetSafeCellValue = Trim(CStr(cell.Value))
End If
On Error GoTo 0
End Function
' 高级单元格比较
Function CompareCellsAdvanced(cell1 As Range, cell2 As Range) As Boolean
Dim val1 As String, val2 As String
val1 = GetSafeCellValue(cell1)
val2 = GetSafeCellValue(cell2)
' 处理数字和文本
If IsNumeric(val1) And IsNumeric(val2) Then
CompareCellsAdvanced = (CDbl(val1) <> CDbl(val2))
Else
CompareCellsAdvanced = (val1 <> val2)
End If
End Function
' 标记独有行
Sub MarkUniqueRow(ws As Worksheet, rowNum As Long, isFileA As Boolean)
If isFileA Then
' A文件独有 - 橙色
ws.Cells(rowNum, 3).Interior.Color = RGB(255, 220, 180) ' C列
ws.Cells(rowNum, 4).Interior.Color = RGB(255, 220, 180) ' D列
ws.Cells(rowNum, 7).Interior.Color = RGB(255, 220, 180) ' G列
ws.Cells(rowNum, 9).Interior.Color = RGB(255, 220, 180) ' I列
Else
' B文件独有 - 浅橙色
ws.Cells(rowNum, 3).Interior.Color = RGB(255, 240, 200) ' C列
ws.Cells(rowNum, 4).Interior.Color = RGB(255, 240, 200) ' D列
ws.Cells(rowNum, 7).Interior.Color = RGB(255, 240, 200) ' G列
ws.Cells(rowNum, 9).Interior.Color = RGB(255, 240, 200) ' I列
End If
End Sub
' 安全的层次处理
Sub ProcessHierarchySafe(ws As Worksheet, lastRow As Long)
Dim i As Long
Dim level As String
For i = 2 To lastRow
' 只处理有编码的行
If GetSafeCellValue(ws.Cells(i, 2)) <> "" Then
level = GetSafeCellValue(ws.Cells(i, 1))
If level <> "" Then
' 计算层级深度
Dim levelNum As Integer
levelNum = Len(level) - Len(Replace(level, ".", ""))
' 为子件名称添加缩进
ws.Cells(i, 3).IndentLevel = levelNum
' 为层次列添加样式
With ws.Cells(i, 1)
.Font.Bold = (levelNum = 0) ' 一级层次加粗
Select Case levelNum
Case 0: .Font.Color = RGB(0, 0, 150) ' 深蓝色
Case 1: .Font.Color = RGB(0, 100, 0) ' 深绿色
Case 2: .Font.Color = RGB(150, 0, 0) ' 深红色
Case 3: .Font.Color = RGB(100, 0, 100) ' 紫色
Case 4: .Font.Color = RGB(0, 100, 100) ' 深青色
Case 5: .Font.Color = RGB(100, 100, 0) ' 橄榄色
End Select
End With
End If
End If
Next i
End Sub
' 高亮显示差异编码
Sub HighlightDifferencesWithComments(ws As Worksheet, lastRow As Long, commentCol As Long)
Dim i As Long
For i = 2 To lastRow
' 只处理有对比结果的编码行
If Not IsEmpty(ws.Cells(i, commentCol).Value) Then
Dim commentText As String
commentText = CStr(ws.Cells(i, commentCol).Value)
' 根据注释内容设置编码列样式
If InStr(commentText, "有差异") > 0 Then
ws.Cells(i, 2).Font.Bold = True
ws.Cells(i, 2).Font.Color = RGB(200, 0, 0)
ws.Cells(i, 2).Interior.Color = RGB(255, 240, 240)
ElseIf InStr(commentText, "无此编码") > 0 Then
ws.Cells(i, 2).Font.Bold = True
ws.Cells(i, 2).Font.Color = RGB(200, 100, 0)
ws.Cells(i, 2).Interior.Color = RGB(255, 240, 220)
ElseIf commentText = "编码重复" Then
ws.Cells(i, 2).Font.Bold = True
ws.Cells(i, 2).Font.Color = RGB(150, 0, 150)
ws.Cells(i, 2).Interior.Color = RGB(240, 220, 240)
ElseIf commentText = "一致" Then
ws.Cells(i, 2).Font.Color = RGB(0, 100, 0)
End If
End If
Next i
End Sub本创作借助腾讯元宝互动完成。
--本站原创，转发需注明出处。
内页底部广告（PC版），后台可以自由更改
9KKD.com
9KKD.com
这里的内容可以随意更改，在后台-主题配置中设置。
百度推荐获取地址：http://tuijian.baidu.com/，百度推荐可能会有一些未知的问题，使用中有任何问题请直接联系百度官方客服！