◎欢迎参与讨论，请在这里发表您的看法、交流您的观点。
用对AI，效率快的不得了！！！产品清单比较宏代码
摘要：
两份排序杂乱无章的产品清单，使用下面的宏代码，16秒搞定！功能特点:...
总字数：75677两份排序杂乱无章的产品清单，使用下面的宏代码，16秒搞定！
功能特点:
✅ 完整功能：支持.xls/.xlsx/.xlsm/.xlsb全格式对比
✅ 智能对比：以编码为主键，双向查找对比
✅ 差异标记：红色/绿色标注不同数据，橙色标注独有编码
✅ 注释系统：详细说明差异位置和类型
✅ 层次处理：自动识别BOM层级关系
✅ 性能优化：字典索引快速查找，跳过空行
✅ 结果统计：完整对比报告和用时统计
制造业、供应链管理或物料清单管理需要频繁对比BOM文件，能大幅提高工作效率。
使用方法:
Excel先开启宏，文件/选项/信任中心/~设置-宏设置-选择:启用所有宏
打开第一个文件，按Alt+F11打开宏编辑界面，插入-模块，复制宏代码，
再回到第一个文件，按Alt+F8，点执行，打开第二个文件即可对比完成。
Option Explicit
' ============================================================
' 主程序：BOM文件智能对比（优化列位置版）
' ============================================================
Sub CompareBOMFilesIntelligent()
Dim wbA As Workbook, wbB As Workbook
Dim wsA As Worksheet, wsB As Worksheet
Dim lastRowA As Long, lastRowB As Long
Dim startTime As Double, totalTime As Double, indexTime As Double
Dim i As Long, j As Long, foundRow As Long
Dim diffDetails As String, matchMethod As String
' 记录开始时间
startTime = Timer
On Error GoTo ErrorHandler
' 设置主工作簿
Set wbA = ThisWorkbook
Set wsA = wbA.Sheets(1)
' 选择B文件
Dim filePathB As String
filePathB = Application.GetOpenFilename("Excel文件 (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", , "请选择B文件")
If filePathB = "False" Then Exit Sub
' 打开B文件
Dim fileExt As String
fileExt = LCase(Right(filePathB, 4))
If fileExt = ".xls" Then
Set wbB = Workbooks.Open(filePathB, UpdateLinks:=False, ReadOnly:=True)
Else
Set wbB = Workbooks.Open(filePathB, UpdateLinks:=False, ReadOnly:=True)
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 Or lastRowB <= 1 Then
MsgBox "文件没有有效数据。", vbExclamation
GoTo Cleanup
End If
' 优化性能设置
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
' 清除格式
ClearAllFormats wsA, lastRowA
ClearAllFormats wsB, lastRowB
' 添加对比结果列（从J列开始，避开I列）
Dim commentColA As Long, commentColB As Long
commentColA = GetLastColumn(wsA) + 2 ' 增加1列，从J列开始
commentColB = GetLastColumn(wsB) + 2
' 确保列位置正确
If commentColA < 10 Then commentColA = 10 ' 确保从J列（第10列）开始
If commentColB < 10 Then commentColB = 10
' 设置标题
SetupCommentHeaders wsA, commentColA, "A"
SetupCommentHeaders wsB, commentColB, "B"
' 添加版本差异列（从K列开始）
Dim versionColA As Long, versionColB As Long
versionColA = commentColA + 1
versionColB = commentColB + 1
SetupVersionHeaders wsA, versionColA, "A"
SetupVersionHeaders wsB, versionColB, "B"
' ========== 阶段1：建立B文件多层智能索引 ==========
indexTime = Timer
' 创建多层索引字典
Dim dictFullCode As Object ' 完整编码索引
Dim dictFirst9Code As Object ' 前9位编码索引
Dim dictCodeC As Object ' 编码+C列索引
Dim dictFirst9CodeC As Object ' 前9位编码+C列索引
Dim dictCDI As Object ' C列+D列+I列索引
Dim dictCI As Object ' C列+I列索引
Dim dictC As Object ' C列索引
Set dictFullCode = CreateObject("Scripting.Dictionary")
Set dictFirst9Code = CreateObject("Scripting.Dictionary")
Set dictCodeC = CreateObject("Scripting.Dictionary")
Set dictFirst9CodeC = CreateObject("Scripting.Dictionary")
Set dictCDI = CreateObject("Scripting.Dictionary")
Set dictCI = CreateObject("Scripting.Dictionary")
Set dictC = CreateObject("Scripting.Dictionary")
' 索引统计
Dim indexStats(1 To 7) As Long
For i = 1 To 7
indexStats(i) = 0
Next i
' 批量读取B文件数据到数组（B列到I列，I列是第9列）
Dim bData() As Variant
Dim bRange As Range
Set bRange = wsB.Range("B2:I" & lastRowB)
bData = bRange.Value
' 建立多层索引
For i = 1 To UBound(bData, 1)
Dim codeB As String, cValueB As String, dValueB As String, iValueB As String
Dim first9CodeB As String
' 获取数据（使用Trim去除首尾空格）
codeB = TrimText(bData(i, 1)) ' B列
cValueB = TrimText(bData(i, 2)) ' C列
dValueB = TrimText(bData(i, 3)) ' D列
iValueB = TrimText(bData(i, 8)) ' I列（第8列对应数组索引8）
' 解析12位物料编码
If Len(codeB) >= 9 Then
first9CodeB = Left(codeB, 9)
End If
' 1. 完整编码索引
If codeB <> "" And Len(codeB) = 12 Then
If Not dictFullCode.Exists(codeB) Then
dictFullCode.Add codeB, i
indexStats(1) = indexStats(1) + 1
End If
End If
' 2. 前9位编码索引
If first9CodeB <> "" And Len(first9CodeB) = 9 Then
If Not dictFirst9Code.Exists(first9CodeB) Then
dictFirst9Code.Add first9CodeB, i
indexStats(2) = indexStats(2) + 1
End If
End If
' 3. 编码+C列索引
If codeB <> "" And cValueB <> "" Then
Dim keyCodeC As String
keyCodeC = codeB & "||" & cValueB
If Not dictCodeC.Exists(keyCodeC) Then
dictCodeC.Add keyCodeC, i
indexStats(3) = indexStats(3) + 1
End If
End If
' 4. 前9位编码+C列索引
If first9CodeB <> "" And cValueB <> "" Then
Dim keyFirst9CodeC As String
keyFirst9CodeC = first9CodeB & "||" & cValueB
If Not dictFirst9CodeC.Exists(keyFirst9CodeC) Then
dictFirst9CodeC.Add keyFirst9CodeC, i
indexStats(4) = indexStats(4) + 1
End If
End If
' 5. C列+D列+I列组合索引
If cValueB <> "" And dValueB <> "" And iValueB <> "" Then
Dim keyCDI As String
keyCDI = cValueB & "||" & dValueB & "||" & iValueB
If Not dictCDI.Exists(keyCDI) Then
dictCDI.Add keyCDI, i
indexStats(5) = indexStats(5) + 1
End If
End If
' 6. C列+I列索引
If cValueB <> "" And iValueB <> "" Then
Dim keyCI As String
keyCI = cValueB & "||" & iValueB
If Not dictCI.Exists(keyCI) Then
dictCI.Add keyCI, i
indexStats(6) = indexStats(6) + 1
End If
End If
' 7. C列索引
If cValueB <> "" Then
If Not dictC.Exists(cValueB) Then
dictC.Add cValueB, i
indexStats(7) = indexStats(7) + 1
End If
End If
Next i
indexTime = Timer - indexTime
' ========== 阶段2：批量读取A文件数据 ==========
Dim aData() As Variant
Dim aRange As Range
Set aRange = wsA.Range("B2:I" & lastRowA)
aData = aRange.Value
' ========== 阶段3：智能匹配对比 ==========
Dim matchStats As Object
Set matchStats = CreateObject("Scripting.Dictionary")
matchStats.Add "跳过", 0
matchStats.Add "完全编码匹配", 0
matchStats.Add "物料版本不同", 0
matchStats.Add "编码+C列匹配", 0
matchStats.Add "前9位编码+C列匹配", 0
matchStats.Add "CDI匹配", 0
matchStats.Add "CI匹配", 0
matchStats.Add "C列匹配", 0
matchStats.Add "未匹配", 0
Dim diffCount As Long, versionDiffCount As Long
diffCount = 0
versionDiffCount = 0
' 记录已匹配的B文件行
Dim matchedRowsB As Object
Set matchedRowsB = CreateObject("Scripting.Dictionary")
' 记录版本差异
Dim versionDiffs As Object
Set versionDiffs = CreateObject("Scripting.Dictionary")
' 智能匹配主循环
For i = 1 To UBound(aData, 1)
Dim codeA As String, cValueA As String, dValueA As String, gValueA As String, iValueA As String
Dim first9CodeA As String, last3CodeA As String
' 获取A文件数据（使用Trim去除首尾空格）
codeA = TrimText(aData(i, 1)) ' B列
cValueA = TrimText(aData(i, 2)) ' C列
dValueA = TrimText(aData(i, 3)) ' D列
gValueA = TrimText(aData(i, 6)) ' G列
iValueA = TrimText(aData(i, 8)) ' I列
' 解析A文件编码
If Len(codeA) >= 9 Then
first9CodeA = Left(codeA, 9)
If Len(codeA) = 12 Then
last3CodeA = Mid(codeA, 10, 3)
End If
End If
' 检查是否为完全空行（不标注）
If IsCompletelyEmptyRow(codeA, cValueA, dValueA, gValueA, iValueA) Then
matchStats("跳过") = matchStats("跳过") + 1
GoTo ContinueLoopA
End If
' 检查是否需要对比
If Not HasContentToCompare(codeA, cValueA, dValueA, iValueA) Then
matchStats("跳过") = matchStats("跳过") + 1
GoTo ContinueLoopA
End If
' 智能匹配查找
foundRow = 0
matchMethod = ""
' 优先级1：完整12位编码匹配
If codeA <> "" And Len(codeA) = 12 Then
If dictFullCode.Exists(codeA) Then
foundRow = dictFullCode(codeA)
matchMethod = "完全编码匹配"
matchStats("完全编码匹配") = matchStats("完全编码匹配") + 1
End If
End If
' 优先级2：前9位编码匹配
If foundRow = 0 And first9CodeA <> "" Then
If dictFirst9Code.Exists(first9CodeA) Then
foundRow = dictFirst9Code(first9CodeA)
Dim matchedCodeB As String
matchedCodeB = TrimText(bData(foundRow, 1))
' 检查是否是完全匹配
If codeA = matchedCodeB Then
' 完全相同的编码
matchMethod = "完全匹配"
matchStats("完全编码匹配") = matchStats("完全编码匹配") + 1
ElseIf Len(matchedCodeB) = 12 Then
' 前9位相同，后3位不同
Dim matchedLast3CodeB As String
matchedLast3CodeB = Mid(matchedCodeB, 10, 3)
matchMethod = "物料版本不同"
matchStats("物料版本不同") = matchStats("物料版本不同") + 1
' 记录版本差异
versionDiffs.Add "A" & (i + 1) & "-B" & (foundRow + 1), last3CodeA & " vs " & matchedLast3CodeB
versionDiffCount = versionDiffCount + 1
End If
End If
End If
' 优先级3：编码+C列匹配
If foundRow = 0 And codeA <> "" And cValueA <> "" Then
Dim keyCodeCA As String
keyCodeCA = codeA & "||" & cValueA
If dictCodeC.Exists(keyCodeCA) Then
foundRow = dictCodeC(keyCodeCA)
matchMethod = "编码+C列匹配"
matchStats("编码+C列匹配") = matchStats("编码+C列匹配") + 1
End If
End If
' 优先级4：前9位编码+C列匹配
If foundRow = 0 And first9CodeA <> "" And cValueA <> "" Then
Dim keyFirst9CodeCA As String
keyFirst9CodeCA = first9CodeA & "||" & cValueA
If dictFirst9CodeC.Exists(keyFirst9CodeCA) Then
foundRow = dictFirst9CodeC(keyFirst9CodeCA)
matchMethod = "前9位编码+C列匹配"
matchStats("前9位编码+C列匹配") = matchStats("前9位编码+C列匹配") + 1
End If
End If
' 优先级5：C列+D列+I列匹配
If foundRow = 0 And cValueA <> "" And dValueA <> "" And iValueA <> "" Then
Dim keyCDIA As String
keyCDIA = cValueA & "||" & dValueA & "||" & iValueA
If dictCDI.Exists(keyCDIA) Then
foundRow = dictCDI(keyCDIA)
matchMethod = "CDI匹配"
matchStats("CDI匹配") = matchStats("CDI匹配") + 1
End If
End If
' 优先级6：C列+I列匹配
If foundRow = 0 And cValueA <> "" And iValueA <> "" Then
Dim keyCIA As String
keyCIA = cValueA & "||" & iValueA
If dictCI.Exists(keyCIA) Then
foundRow = dictCI(keyCIA)
matchMethod = "CI匹配"
matchStats("CI匹配") = matchStats("CI匹配") + 1
End If
End If
' 优先级7：C列匹配
If foundRow = 0 And cValueA <> "" Then
If dictC.Exists(cValueA) Then
foundRow = dictC(cValueA)
matchMethod = "C列匹配"
matchStats("C列匹配") = matchStats("C列匹配") + 1
End If
End If
' 处理匹配结果
If foundRow > 0 Then
' 标记已匹配
If Not matchedRowsB.Exists(foundRow) Then
matchedRowsB.Add foundRow, True
End If
' 对比详细数据
diffDetails = ""
Dim hasDiff As Boolean
hasDiff = False
' 对比C列
Dim cValueBCompare As String
cValueBCompare = TrimText(bData(foundRow, 2))
If CompareDataAdvanced(cValueA, cValueBCompare) Then
wsA.Cells(i + 1, 3).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow + 1, 3).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & "C"
hasDiff = True
End If
' 对比D列（数量）
Dim dValueBCompare As String
dValueBCompare = TrimText(bData(foundRow, 3))
If CompareDataAdvanced(dValueA, dValueBCompare) Then
wsA.Cells(i + 1, 4).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow + 1, 4).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & IIf(diffDetails = "", "D", "/D")
hasDiff = True
End If
' 对比G列（单位）
If gValueA <> "" And codeA <> "" Then
Dim gValueB As String
gValueB = TrimText(bData(foundRow, 6))
If CompareDataAdvanced(gValueA, gValueB) Then
wsA.Cells(i + 1, 7).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow + 1, 7).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & IIf(diffDetails = "", "G", "/G")
hasDiff = True
End If
End If
' 对比I列
Dim iValueBCompare As String
iValueBCompare = TrimText(bData(foundRow, 8))
If CompareDataAdvanced(iValueA, iValueBCompare) Then
wsA.Cells(i + 1, 9).Interior.Color = RGB(255, 200, 200)
wsB.Cells(foundRow + 1, 9).Interior.Color = RGB(200, 255, 200)
diffDetails = diffDetails & IIf(diffDetails = "", "I", "/I")
hasDiff = True
End If
' 添加对比结果
If hasDiff Then
wsA.Cells(i + 1, commentColA).Value = matchMethod & "但有差异[" & diffDetails & "]"
wsA.Cells(i + 1, commentColA).Interior.Color = GetMatchColor(matchMethod, True)
wsB.Cells(foundRow + 1, commentColB).Value = matchMethod & "但有差异[" & diffDetails & "]"
wsB.Cells(foundRow + 1, commentColB).Interior.Color = GetMatchColor(matchMethod, False)
diffCount = diffCount + 1
Else
wsA.Cells(i + 1, commentColA).Value = matchMethod
wsA.Cells(i + 1, commentColA).Interior.Color = GetMatchColor(matchMethod, True)
wsB.Cells(foundRow + 1, commentColB).Value = matchMethod
wsB.Cells(foundRow + 1, commentColB).Interior.Color = GetMatchColor(matchMethod, False)
End If
' 添加版本差异提示
If versionDiffs.Exists("A" & (i + 1) & "-B" & (foundRow + 1)) Then
Dim versionMsg As String
versionMsg = "物料版本不同: " & versionDiffs("A" & (i + 1) & "-B" & (foundRow + 1))
wsA.Cells(i + 1, versionColA).Value = versionMsg
wsB.Cells(foundRow + 1, versionColB).Value = versionMsg
wsA.Cells(i + 1, versionColA).Interior.Color = RGB(255, 240, 200)
wsB.Cells(foundRow + 1, versionColB).Interior.Color = RGB(255, 240, 200)
End If
Else
' 未找到匹配
wsA.Cells(i + 1, commentColA).Value = "B文件无对应数据"
wsA.Cells(i + 1, commentColA).Interior.Color = RGB(255, 220, 180)
MarkUniqueRow wsA, i + 1, True
matchStats("未匹配") = matchStats("未匹配") + 1
End If
ContinueLoopA:
Next i
' ========== 阶段4：标记B文件独有数据 ==========
For i = 1 To UBound(bData, 1)
If Not matchedRowsB.Exists(i) Then
wsB.Cells(i + 1, commentColB).Value = "A文件无对应数据"
wsB.Cells(i + 1, commentColB).Interior.Color = RGB(255, 240, 200)
MarkUniqueRow wsB, i + 1, False
End If
Next i
' 处理层次关系
ProcessHierarchySafe wsA, lastRowA
ProcessHierarchySafe wsB, lastRowB
Cleanup:
' 恢复设置
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.DisplayAlerts = True
' 调整列宽
AutoFitColumnsExcludeA wsA, versionColA
AutoFitColumnsExcludeA wsB, versionColB
' 高亮差异
HighlightDifferencesWithComments wsA, lastRowA, commentColA
HighlightDifferencesWithComments wsB, lastRowB, commentColB
' 计算总用时
totalTime = Timer - startTime
' 生成详细报告
Dim msg As String
msg = GenerateReport(lastRowA, lastRowB, indexStats, matchStats, diffCount, versionDiffCount, indexTime, totalTime)
MsgBox msg, vbInformation, "BOM智能对比完成"
' 保存选项
Dim response As VbMsgBoxResult
response = MsgBox("B文件对比结果已标记。是否保存B文件？", vbQuestion + vbYesNo, "保存文件")
If response = vbYes Then
Dim savePath As String, 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
On Error GoTo 0
End If
wbB.Close SaveChanges:=(response = vbYes)
' 清理对象
Set dictFullCode = Nothing
Set dictFirst9Code = Nothing
Set dictCodeC = Nothing
Set dictFirst9CodeC = Nothing
Set dictCDI = Nothing
Set dictCI = Nothing
Set dictC = Nothing
Set matchedRowsB = Nothing
Set versionDiffs = Nothing
Set matchStats = Nothing
Exit Sub
ErrorHandler:
MsgBox "错误 " & Err.Number & ": " & Err.Description, vbCritical, "对比失败"
GoTo Cleanup
End Sub
' ============================================================
' 辅助函数
' ============================================================
' 安全的字符串转换（去除首尾空格）
Function TrimText(ByVal val As Variant) As String
On Error Resume Next
If IsError(val) Then
TrimText = ""
ElseIf IsNull(val) Then
TrimText = ""
ElseIf val = "" Then
TrimText = ""
Else
TrimText = Trim(CStr(val))
End If
On Error GoTo 0
End Function
' 获取最后一行
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
' 获取最后一列
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
' 自动调整列宽（排除A列）
Sub AutoFitColumnsExcludeA(ws As Worksheet, lastCol As Long)
On Error Resume Next
' 记录A列当前宽度
Dim aColWidth As Double
aColWidth = ws.Columns("A:A").ColumnWidth
' 调整B列到最后一列的宽度
If lastCol > 2 Then
Dim colRange As Range
Set colRange = ws.Range(ws.Cells(1, 2), ws.Cells(1, lastCol)).EntireColumn
colRange.AutoFit
' 设置对比列宽度
If lastCol >= 10 Then
ws.Columns(lastCol - 1).ColumnWidth = 25
End If
ws.Columns(lastCol).ColumnWidth = 30
End If
' 恢复A列宽度
ws.Columns("A:A").ColumnWidth = aColWidth
' 自动调整行高
ws.Rows.AutoFit
On Error GoTo 0
End Sub
' 设置对比结果标题
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 SetupVersionHeaders(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(255, 240, 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 IsCompletelyEmptyRow(ByVal code As String, ByVal cValue As String, _
ByVal dValue As String, ByVal gValue As String, _
ByVal iValue As String) As Boolean
If code = "" And cValue = "" And dValue = "" And gValue = "" And iValue = "" Then
IsCompletelyEmptyRow = True
Else
IsCompletelyEmptyRow = False
End If
End Function
' 检查是否有内容需要对比
Function HasContentToCompare(ByVal code As String, ByVal cValue As String, _
ByVal dValue As String, ByVal iValue As String) As Boolean
If code <> "" Or cValue <> "" Or dValue <> "" Or iValue <> "" Then
HasContentToCompare = True
Else
HasContentToCompare = False
End If
End Function
' 高级数据对比（忽略首尾空格）
Function CompareDataAdvanced(ByVal val1 As String, ByVal val2 As String) As Boolean
' 去除首尾空格
val1 = Trim(val1)
val2 = Trim(val2)
If val1 = "" And val2 = "" Then
CompareDataAdvanced = False
Exit Function
End If
If val1 = val2 Then
CompareDataAdvanced = False
Exit Function
End If
' 处理数字
If IsNumeric(val1) And IsNumeric(val2) Then
CompareDataAdvanced = (Abs(CDbl(val1) - CDbl(val2)) > 0.0001)
Else
CompareDataAdvanced = (val1 <> val2)
End If
End Function
' 根据匹配方法获取颜色
Function GetMatchColor(ByVal method As String, ByVal isFileA As Boolean) As Long
Select Case method
Case "完全匹配", "完全编码匹配"
GetMatchColor = RGB(220, 255, 220) ' 浅绿
Case "物料版本不同"
GetMatchColor = RGB(255, 240, 220) ' 浅橙
Case "编码+C列匹配"
GetMatchColor = RGB(220, 240, 255) ' 浅蓝
Case "前9位编码+C列匹配"
GetMatchColor = RGB(240, 220, 255) ' 浅紫
Case "CDI匹配"
GetMatchColor = RGB(255, 240, 220) ' 浅橙
Case "CI匹配"
GetMatchColor = RGB(220, 255, 255) ' 浅青
Case "C列匹配"
GetMatchColor = RGB(255, 220, 240) ' 浅粉
Case Else
GetMatchColor = RGB(220, 255, 220) ' 默认浅绿
End Select
End Function
' 标记独有行
Sub MarkUniqueRow(ws As Worksheet, rowNum As Long, isFileA As Boolean)
If isFileA Then
ws.Cells(rowNum, 3).Interior.Color = RGB(255, 220, 180)
ws.Cells(rowNum, 4).Interior.Color = RGB(255, 220, 180)
ws.Cells(rowNum, 7).Interior.Color = RGB(255, 220, 180)
ws.Cells(rowNum, 9).Interior.Color = RGB(255, 220, 180)
Else
ws.Cells(rowNum, 3).Interior.Color = RGB(255, 240, 200)
ws.Cells(rowNum, 4).Interior.Color = RGB(255, 240, 200)
ws.Cells(rowNum, 7).Interior.Color = RGB(255, 240, 200)
ws.Cells(rowNum, 9).Interior.Color = RGB(255, 240, 200)
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
Dim code As String
code = TrimText(ws.Cells(i, 2))
If code <> "" Then
level = TrimText(ws.Cells(i, 1))
If level <> "" Then
Dim levelNum As Integer
levelNum = Len(level) - Len(Replace(level, ".", ""))
ws.Cells(i, 3).IndentLevel = levelNum
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 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, 200)
End If
End If
Next i
End Sub
' 生成详细报告
Function GenerateReport(ByVal lastRowA As Long, ByVal lastRowB As Long, _
ByRef indexStats() As Long, ByRef matchStats As Object, _
ByVal diffCount As Long, ByVal versionDiffCount As Long, _
ByVal indexTime As Double, ByVal totalTime As Double) As String
Dim msg As String
msg = "? BOM智能对比完成" & vbCrLf & String(50, "=") & vbCrLf
' 基本统计
msg = msg & "?? 基本统计：" & vbCrLf
msg = msg & "A文件行数: " & (lastRowA - 1) & " 行" & vbCrLf
msg = msg & "B文件行数: " & (lastRowB - 1) & " 行" & vbCrLf
msg = msg & "跳过行: " & matchStats("跳过") & " 行" & vbCrLf
msg = msg & "数据差异: " & diffCount & " 处" & vbCrLf
msg = msg & "版本差异: " & versionDiffCount & " 处" & vbCrLf & vbCrLf
' 性能统计
msg = msg & "? 性能统计：" & vbCrLf
msg = msg & "总用时: " & Format(totalTime, "0.00") & " 秒" & vbCrLf
msg = msg & "索引建立: " & Format(indexTime, "0.00") & " 秒" & vbCrLf
msg = msg & "对比用时: " & Format(totalTime - indexTime, "0.00") & " 秒" & vbCrLf & vbCrLf
' 索引统计
msg = msg & "?? 索引统计：" & vbCrLf
msg = msg & "1. 完整编码索引: " & indexStats(1) & " 个" & vbCrLf
msg = msg & "2. 前9位编码索引: " & indexStats(2) & " 个" & vbCrLf
msg = msg & "3. 编码+C列索引: " & indexStats(3) & " 个" & vbCrLf
msg = msg & "4. 前9位编码+C列索引: " & indexStats(4) & " 个" & vbCrLf
msg = msg & "5. CDI索引: " & indexStats(5) & " 个" & vbCrLf
msg = msg & "6. CI索引: " & indexStats(6) & " 个" & vbCrLf
msg = msg & "7. C列索引: " & indexStats(7) & " 个" & vbCrLf & vbCrLf
' 匹配统计
msg = msg & "?? 匹配统计：" & vbCrLf
Dim key As Variant
For Each key In matchStats.Keys
If key <> "跳过" Then
msg = msg & "? " & key & ": " & matchStats(key) & vbCrLf
End If
Next key
msg = msg & "? 未匹配: " & matchStats("未匹配") & vbCrLf & vbCrLf
' 匹配优先级说明
msg = msg & "?? 匹配优先级：" & vbCrLf
msg = msg & "1. 完整12位编码匹配" & vbCrLf
msg = msg & "2. 前9位编码（类别+物料）匹配" & vbCrLf
msg = msg & "3. 编码+C列匹配" & vbCrLf
msg = msg & "4. 前9位编码+C列匹配" & vbCrLf
msg = msg & "5. C列+D列+I列匹配" & vbCrLf
msg = msg & "6. C列+I列匹配" & vbCrLf
msg = msg & "7. C列匹配" & vbCrLf
GenerateReport = msg
End Function本创作借助腾讯元宝互动完成。
--本站原创，转发需注明出处。
内页底部广告（PC版），后台可以自由更改
9KKD.com
9KKD.com
这里的内容可以随意更改，在后台-主题配置中设置。
百度推荐获取地址：http://tuijian.baidu.com/，百度推荐可能会有一些未知的问题，使用中有任何问题请直接联系百度官方客服！