7d59e489b1
Implement intelligent BOM error analysis module that: - Extracts and analyzes failed order matching attempts - Uses feature-weight algorithm (azxs=10000, bkxs=1000, etc.) for accurate parameter conflict detection - Automatically traces unmatched parameters to root cause - Splits multi-error results into separate rows for detailed analysis - Exposes BomExtractor data pool via GetAllItems() for external analysis This solves fuzzy tie problems that caused parameter false positives in previous matching logic. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
559 lines
20 KiB
QBasic
559 lines
20 KiB
QBasic
'=====================================================================
|
||
' 模块名: ErrorAnalysisModule
|
||
' 功能: BOM匹配异常分析模块，仅提取报错订单，拆分多行，并自动回溯"未匹配参数"
|
||
' 特性: 采用"特征权重算法"解决模糊平局(Tie)导致的参数误报问题
|
||
'=====================================================================
|
||
|
||
Option Explicit
|
||
|
||
' 提取条件配置
|
||
Private Const CONDITION_CONFIG = "azxs,安装形式|bkxs,表壳形式|gclj,过程连接|jycz,接液材质|lcfw,量程范围|fjgn,附加功能"
|
||
|
||
'=====================================================================
|
||
' 过程: GenerateErrorAnalysisReport
|
||
' 功能: 批量处理产品型号，输出BOM匹配异常报表
|
||
'=====================================================================
|
||
Public Sub GenerateErrorAnalysisReport()
|
||
On Error GoTo ErrorHandler
|
||
|
||
Dim startTime As Double
|
||
startTime = Timer
|
||
|
||
Application.ScreenUpdating = False
|
||
Application.Calculation = xlCalculationManual
|
||
|
||
' 获取工作表
|
||
Dim orderSheet As Worksheet
|
||
Dim bomSheet As Worksheet
|
||
Dim outputSheet As Worksheet
|
||
|
||
Set orderSheet = GetOrderSheet()
|
||
If orderSheet Is Nothing Then
|
||
RestoreAppStatus
|
||
MsgBox "未找到[产品订单]工作表!", vbCritical
|
||
Exit Sub
|
||
End If
|
||
|
||
Set bomSheet = GetBomSheet()
|
||
If bomSheet Is Nothing Then
|
||
RestoreAppStatus
|
||
MsgBox "未找到[平台配置清单]工作表!", vbCritical
|
||
Exit Sub
|
||
End If
|
||
|
||
' 初始化BOM提取器
|
||
Dim BomExtractor As BomExtractor
|
||
Set BomExtractor = New BomExtractor
|
||
BomExtractor.SetWorksheet bomSheet
|
||
|
||
If Not BomExtractor.LoadBomData Then
|
||
RestoreAppStatus
|
||
MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical
|
||
Exit Sub
|
||
End If
|
||
|
||
' 获取或创建输出表
|
||
Set outputSheet = CreateErrorOutputSheet()
|
||
WriteOutputHeader outputSheet
|
||
|
||
' 获取筛选后的订单数据
|
||
Dim lastRow As Long
|
||
lastRow = orderSheet.Cells(orderSheet.Rows.count, 3).End(xlUp).row
|
||
If lastRow < 2 Then
|
||
RestoreAppStatus
|
||
MsgBox "[产品订单]工作表中没有数据!", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim sourceDataArr As Variant
|
||
sourceDataArr = orderSheet.Range("A2:F" & lastRow).value
|
||
|
||
Dim visibleRange As Range
|
||
On Error Resume Next
|
||
Set visibleRange = orderSheet.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible)
|
||
On Error GoTo ErrorHandler
|
||
|
||
If visibleRange Is Nothing Then
|
||
RestoreAppStatus
|
||
MsgBox "当前筛选状态下没有可见的数据。", vbInformation
|
||
Exit Sub
|
||
End If
|
||
|
||
' 初始化正则表达式引擎 (只初始化一次，提速)
|
||
Dim regEx As Object
|
||
Set regEx = CreateObject("VBScript.RegExp")
|
||
regEx.Global = True
|
||
regEx.IgnoreCase = True
|
||
' 匹配如 azxs=A0, fjgn!=N1 这样的条件结构
|
||
regEx.Pattern = "(azxs|bkxs|gclj|jycz|lcfw|fjgn)\s*(!=|=)\s*([A-Za-z0-9_]+)"
|
||
|
||
Dim outputData As Collection
|
||
Set outputData = New Collection
|
||
|
||
Dim cell As Range
|
||
Dim arrIndex As Long
|
||
Dim totalProcessed As Long
|
||
Dim errorOrdersCount As Long
|
||
Dim errorRowsCount As Long
|
||
|
||
totalProcessed = 0
|
||
errorOrdersCount = 0
|
||
errorRowsCount = 0
|
||
|
||
' 遍历可见订单
|
||
For Each cell In visibleRange
|
||
arrIndex = cell.row - 1
|
||
|
||
Dim totalQueueNum As String
|
||
Dim orderNumber As String
|
||
Dim modelString As String
|
||
Dim componentPriority As String
|
||
|
||
totalQueueNum = Trim(sourceDataArr(arrIndex, 1))
|
||
orderNumber = Trim(sourceDataArr(arrIndex, 2))
|
||
modelString = Trim(sourceDataArr(arrIndex, 3))
|
||
componentPriority = Trim(sourceDataArr(arrIndex, 6))
|
||
|
||
If modelString <> "" Then
|
||
totalProcessed = totalProcessed + 1
|
||
|
||
' 解析并匹配BOM
|
||
Dim parser As ProductModelParser
|
||
Set parser = New ProductModelParser
|
||
|
||
Dim hasError As Boolean
|
||
hasError = False
|
||
Dim errors As String
|
||
errors = ""
|
||
|
||
If Not parser.Parse(modelString) Then
|
||
hasError = True
|
||
errors = "型号解析失败: " & parser.ErrorMessage
|
||
Else
|
||
' 提取逻辑
|
||
BomExtractor.ClearExcludeCategories
|
||
If UCase(componentPriority) = "否" Or componentPriority = "0" Or componentPriority = "FALSE" Then
|
||
Dim excludeCats As New Collection
|
||
excludeCats.Add "部件"
|
||
BomExtractor.SetExcludeCategories excludeCats
|
||
End If
|
||
|
||
Dim matchedItems As Collection
|
||
Set matchedItems = BomExtractor.ExtractBom(parser.conditions)
|
||
|
||
errors = BomExtractor.GetErrorSummary()
|
||
If errors <> "" Or matchedItems.count = 0 Then
|
||
hasError = True
|
||
If errors = "" And matchedItems.count = 0 Then
|
||
errors = "完全未匹配到物料"
|
||
End If
|
||
End If
|
||
|
||
' 深度检查BOM行自身的报错（如"匹配到多条"）
|
||
Dim item As BomItem
|
||
For Each item In matchedItems
|
||
If item.MatchError <> "" Then
|
||
hasError = True
|
||
errors = errors & item.category & ":" & item.MatchError & ";"
|
||
End If
|
||
Next item
|
||
End If
|
||
|
||
' 如果存在错误，拆分为多行并寻找未匹配参数
|
||
If hasError Then
|
||
errorOrdersCount = errorOrdersCount + 1
|
||
|
||
Dim errArray() As String
|
||
errArray = Split(errors, ";")
|
||
Dim i As Long
|
||
|
||
For i = LBound(errArray) To UBound(errArray)
|
||
Dim singleError As String
|
||
singleError = Trim(errArray(i))
|
||
|
||
If singleError <> "" Then
|
||
Dim unmatchedValues As String
|
||
unmatchedValues = "无法精准定位"
|
||
|
||
' 如果是型号解析失败，跳过溯源
|
||
If InStr(singleError, "型号解析失败") = 0 And InStr(singleError, "完全未匹配到物料") = 0 Then
|
||
Dim targetCategory As String
|
||
targetCategory = ExtractCategoryName(singleError)
|
||
|
||
If targetCategory <> "" Then
|
||
' 核心：调用带权重的重合度算法定位冲突参数(通过 | 分隔)
|
||
unmatchedValues = FindUnmatchedParameter(targetCategory, parser.conditions, BomExtractor.GetAllItems(), regEx)
|
||
End If
|
||
End If
|
||
|
||
' ---> 拆分未匹配参数，避免糅合在一起
|
||
Dim unmatchArr() As String
|
||
unmatchArr = Split(unmatchedValues, "|")
|
||
|
||
Dim j As Long
|
||
For j = LBound(unmatchArr) To UBound(unmatchArr)
|
||
Dim singleUnmatch As String
|
||
singleUnmatch = Trim(unmatchArr(j))
|
||
If singleUnmatch <> "" Then
|
||
outputData.Add CreateErrorRowArray(totalQueueNum, orderNumber, modelString, parser.conditions, singleUnmatch, singleError)
|
||
errorRowsCount = errorRowsCount + 1
|
||
End If
|
||
Next j
|
||
End If
|
||
Next i
|
||
End If
|
||
End If
|
||
Next cell
|
||
|
||
' 批量写入数据
|
||
If outputData.count > 0 Then
|
||
WriteBatchData outputSheet, outputData
|
||
Else
|
||
MsgBox "太棒了！所选订单均完美匹配BOM，未发现任何异常。", vbInformation
|
||
End If
|
||
|
||
' 格式化表格
|
||
FormatOutputSheet outputSheet
|
||
|
||
RestoreAppStatus
|
||
Dim elapsedTime As Double
|
||
elapsedTime = Timer - startTime
|
||
|
||
MsgBox "异常分析完成!" & vbCrLf & _
|
||
"共检查订单: " & totalProcessed & vbCrLf & _
|
||
"发现异常订单: " & errorOrdersCount & vbCrLf & _
|
||
"生成异常明细: " & errorRowsCount & " 行" & vbCrLf & _
|
||
"用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation
|
||
|
||
outputSheet.Activate
|
||
Exit Sub
|
||
|
||
ErrorHandler:
|
||
RestoreAppStatus
|
||
MsgBox "异常分析发生错误: " & Err.Description, vbCritical
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 核心算法: FindUnmatchedParameter (带权重的最大特征重合度算法)
|
||
' 功能: 分析BOM库，找出与当前订单特征最相似的物料，并提取冲突(未匹配)的参数值
|
||
'=====================================================================
|
||
Private Function FindUnmatchedParameter(category As String, productConds As Object, allBomItems As Collection, regEx As Object) As String
|
||
' 使用 Long 类型，因为加入权重后得分会超过 Integer 上限
|
||
Dim maxScore As Long
|
||
maxScore = -1
|
||
Dim bestConflictKeys As String
|
||
bestConflictKeys = ""
|
||
|
||
Dim item As BomItem
|
||
|
||
' 遍历BOM库中同类别的所有物料
|
||
For Each item In allBomItems
|
||
If item.category = category And Trim(item.SelectCondition) <> "" Then
|
||
|
||
Dim allowed As Object
|
||
Set allowed = CreateObject("Scripting.Dictionary")
|
||
Dim forbidden As Object
|
||
Set forbidden = CreateObject("Scripting.Dictionary")
|
||
|
||
' 使用正则提取该物料的所有约束条件 (如 azxs=A0)
|
||
Dim matches As Object
|
||
Set matches = regEx.Execute(item.SelectCondition)
|
||
|
||
Dim match As Object
|
||
For Each match In matches
|
||
Dim k As String, op As String, v As String
|
||
k = match.SubMatches(0)
|
||
op = Trim(match.SubMatches(1))
|
||
v = Trim(match.SubMatches(2))
|
||
|
||
If op = "=" Then
|
||
If Not allowed.Exists(k) Then allowed(k) = "|"
|
||
allowed(k) = allowed(k) & v & "|"
|
||
ElseIf op = "!=" Or op = "<>" Then
|
||
If Not forbidden.Exists(k) Then forbidden(k) = "|"
|
||
forbidden(k) = forbidden(k) & v & "|"
|
||
End If
|
||
Next match
|
||
|
||
' 合并出现过的所有参数键
|
||
Dim allRuleKeys As Object
|
||
Set allRuleKeys = CreateObject("Scripting.Dictionary")
|
||
|
||
Dim vKey As Variant
|
||
For Each vKey In allowed.Keys: allRuleKeys(vKey) = True: Next vKey
|
||
For Each vKey In forbidden.Keys: allRuleKeys(vKey) = True: Next vKey
|
||
|
||
Dim currentScore As Long
|
||
currentScore = 0
|
||
Dim currentConflicts As String
|
||
currentConflicts = ""
|
||
|
||
' 计算该物料与实际订单参数的重合度得分
|
||
Dim keyVar As Variant
|
||
For Each keyVar In allRuleKeys.Keys
|
||
Dim keyStr As String
|
||
keyStr = CStr(keyVar)
|
||
|
||
Dim prodVal As String
|
||
If productConds.Exists(keyStr) Then prodVal = productConds(keyStr) Else prodVal = ""
|
||
|
||
Dim isMatch As Boolean
|
||
isMatch = False
|
||
|
||
If allowed.Exists(keyStr) Then
|
||
' 如果实际值包含在允许值中，则得分
|
||
If InStr(allowed(keyStr), "|" & prodVal & "|") > 0 Then
|
||
isMatch = True
|
||
End If
|
||
ElseIf forbidden.Exists(keyStr) Then
|
||
' 如果没有允许值限制，只有禁止值限制，且实际值不在禁止值中，则得分
|
||
If InStr(forbidden(keyStr), "|" & prodVal & "|") = 0 Then
|
||
isMatch = True
|
||
End If
|
||
End If
|
||
|
||
If isMatch Then
|
||
' 【核心修改】引入特征权重，让系统具备业务直觉
|
||
currentScore = currentScore + GetFeatureWeight(keyStr)
|
||
Else
|
||
currentConflicts = currentConflicts & keyStr & ","
|
||
End If
|
||
Next keyVar
|
||
|
||
' 更新最高得分记录
|
||
If currentScore > maxScore Then
|
||
maxScore = currentScore
|
||
bestConflictKeys = currentConflicts
|
||
ElseIf currentScore = maxScore And currentScore > 0 Then
|
||
' 如果权重得分依然相同，合并所有可能的冲突原因
|
||
Dim keysArray() As String
|
||
keysArray = Split(currentConflicts, ",")
|
||
Dim cKey As Variant
|
||
For Each cKey In keysArray
|
||
If Trim(cKey) <> "" And InStr(bestConflictKeys, cKey & ",") = 0 Then
|
||
bestConflictKeys = bestConflictKeys & cKey & ","
|
||
End If
|
||
Next cKey
|
||
End If
|
||
|
||
End If
|
||
Next item
|
||
|
||
' 将最高分的冲突Key翻译为实际的参数值
|
||
If bestConflictKeys <> "" Then
|
||
Dim resultStr As String
|
||
resultStr = ""
|
||
Dim finalKeys() As String
|
||
finalKeys = Split(bestConflictKeys, ",")
|
||
|
||
Dim fKey As Variant
|
||
For Each fKey In finalKeys
|
||
If Trim(fKey) <> "" Then
|
||
Dim actVal As String
|
||
If productConds.Exists(fKey) Then actVal = productConds(fKey) Else actVal = "无值"
|
||
|
||
' 使用 | 作为分隔符进行拼接去重
|
||
If resultStr = "" Then
|
||
resultStr = actVal
|
||
Else
|
||
If InStr("|" & resultStr & "|", "|" & actVal & "|") = 0 Then
|
||
resultStr = resultStr & "|" & actVal
|
||
End If
|
||
End If
|
||
End If
|
||
Next fKey
|
||
|
||
If resultStr <> "" Then
|
||
FindUnmatchedParameter = resultStr
|
||
Else
|
||
FindUnmatchedParameter = "无法精准定位"
|
||
End If
|
||
Else
|
||
FindUnmatchedParameter = "无法精准定位"
|
||
End If
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 辅助函数: GetFeatureWeight
|
||
' 功能: 获取字段的匹配权重，严格保证高优先级特征的决定性
|
||
'=====================================================================
|
||
Private Function GetFeatureWeight(keyStr As String) As Long
|
||
Select Case LCase(Trim(keyStr))
|
||
Case "azxs"
|
||
GetFeatureWeight = 10000 ' 安装形式 - 决定物理结构，最重要
|
||
Case "bkxs"
|
||
GetFeatureWeight = 1000 ' 表壳形式
|
||
Case "gclj"
|
||
GetFeatureWeight = 100 ' 过程连接
|
||
Case "jycz"
|
||
GetFeatureWeight = 50 ' 接液材质
|
||
Case "lcfw"
|
||
GetFeatureWeight = 10 ' 量程范围
|
||
Case "fjgn"
|
||
GetFeatureWeight = 1 ' 附加功能
|
||
Case Else
|
||
GetFeatureWeight = 0
|
||
End Select
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 辅助函数: ExtractCategoryName
|
||
' 功能: 从报错文本如 "必需类别[部件]未匹配" 中提取出 "部件"
|
||
'=====================================================================
|
||
Private Function ExtractCategoryName(errorMsg As String) As String
|
||
Dim startPos As Long
|
||
Dim endPos As Long
|
||
startPos = InStr(errorMsg, "[")
|
||
endPos = InStr(errorMsg, "]")
|
||
|
||
If startPos > 0 And endPos > startPos Then
|
||
ExtractCategoryName = Mid(errorMsg, startPos + 1, endPos - startPos - 1)
|
||
Else
|
||
ExtractCategoryName = ""
|
||
End If
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 过程: WriteOutputHeader
|
||
'=====================================================================
|
||
Private Sub WriteOutputHeader(ws As Worksheet)
|
||
Dim col As Long
|
||
col = 1
|
||
|
||
ws.Cells(1, col).value = "总排号": col = col + 1
|
||
ws.Cells(1, col).value = "生产订单号": col = col + 1
|
||
ws.Cells(1, col).value = "产品型号": col = col + 1
|
||
|
||
Dim configs() As String
|
||
configs = Split(CONDITION_CONFIG, "|")
|
||
Dim i As Long
|
||
For i = LBound(configs) To UBound(configs)
|
||
ws.Cells(1, col).value = Trim(Split(configs(i), ",")(1))
|
||
col = col + 1
|
||
Next i
|
||
|
||
ws.Cells(1, col).value = "未匹配参数": col = col + 1
|
||
ws.Cells(1, col).value = "提取备注": col = col + 1
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 函数: CreateErrorRowArray
|
||
' 功能: 构建输出的一行数据
|
||
'=====================================================================
|
||
Private Function CreateErrorRowArray(totalQueueNum As String, orderNumber As String, _
|
||
modelStr As String, conditions As Object, _
|
||
unmatchedValue As String, errorNote As String) As Variant()
|
||
Dim configs() As String
|
||
configs = Split(CONDITION_CONFIG, "|")
|
||
|
||
Dim totalCols As Long
|
||
totalCols = 3 + UBound(configs) - LBound(configs) + 1 + 2
|
||
|
||
ReDim rowData(1 To totalCols) As Variant
|
||
Dim col As Long
|
||
col = 1
|
||
|
||
rowData(col) = totalQueueNum: col = col + 1
|
||
rowData(col) = orderNumber: col = col + 1
|
||
rowData(col) = modelStr: col = col + 1
|
||
|
||
Dim i As Long
|
||
For i = LBound(configs) To UBound(configs)
|
||
Dim key As String
|
||
key = Trim(Split(configs(i), ",")(0))
|
||
If conditions.Exists(key) Then
|
||
rowData(col) = conditions(key)
|
||
Else
|
||
rowData(col) = ""
|
||
End If
|
||
col = col + 1
|
||
Next i
|
||
|
||
rowData(col) = unmatchedValue: col = col + 1
|
||
rowData(col) = errorNote: col = col + 1
|
||
|
||
CreateErrorRowArray = rowData
|
||
End Function
|
||
|
||
'=====================================================================
|
||
' 过程: WriteBatchData
|
||
'=====================================================================
|
||
Private Sub WriteBatchData(ws As Worksheet, outputData As Collection)
|
||
Dim firstRow As Variant
|
||
firstRow = outputData(1)
|
||
|
||
Dim rowCount As Long
|
||
Dim colCount As Long
|
||
rowCount = outputData.count
|
||
colCount = UBound(firstRow) - LBound(firstRow) + 1
|
||
|
||
Dim resultData() As Variant
|
||
ReDim resultData(1 To rowCount, 1 To colCount)
|
||
|
||
Dim i As Long, j As Long
|
||
Dim rowArray As Variant
|
||
For i = 1 To rowCount
|
||
rowArray = outputData(i)
|
||
For j = 1 To colCount
|
||
resultData(i, j) = rowArray(j)
|
||
Next j
|
||
Next i
|
||
|
||
ws.Range("A2").Resize(rowCount, colCount).value = resultData
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 辅助过程
|
||
'=====================================================================
|
||
Private Function GetOrderSheet() As Worksheet
|
||
On Error Resume Next
|
||
Set GetOrderSheet = ThisWorkbook.Worksheets("产品订单")
|
||
If GetOrderSheet Is Nothing Then Set GetOrderSheet = ActiveSheet
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
Private Function GetBomSheet() As Worksheet
|
||
On Error Resume Next
|
||
Set GetBomSheet = ThisWorkbook.Worksheets("平台配置清单")
|
||
On Error GoTo 0
|
||
End Function
|
||
|
||
Private Function CreateErrorOutputSheet() As Worksheet
|
||
Dim wsName As String
|
||
wsName = "BOM匹配异常报表"
|
||
On Error Resume Next
|
||
Set CreateErrorOutputSheet = ThisWorkbook.Worksheets(wsName)
|
||
On Error GoTo 0
|
||
|
||
If CreateErrorOutputSheet Is Nothing Then
|
||
Set CreateErrorOutputSheet = ThisWorkbook.Worksheets.Add
|
||
CreateErrorOutputSheet.Name = wsName
|
||
Else
|
||
CreateErrorOutputSheet.Cells.Clear
|
||
End If
|
||
End Function
|
||
|
||
Private Sub FormatOutputSheet(ws As Worksheet)
|
||
On Error Resume Next
|
||
With ws.Rows(1)
|
||
.Font.Bold = True
|
||
.Interior.Color = RGB(244, 176, 132) ' 橙色背景，突出异常属性
|
||
.HorizontalAlignment = xlCenter
|
||
End With
|
||
|
||
' 将"未匹配参数"列(倒数第2列)加粗显示，颜色标红
|
||
Dim unmatchCol As Long
|
||
unmatchCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column - 1
|
||
If unmatchCol > 0 Then
|
||
ws.Columns(unmatchCol).Font.Color = RGB(255, 0, 0)
|
||
ws.Columns(unmatchCol).Font.Bold = True
|
||
End If
|
||
|
||
ws.Columns.AutoFit
|
||
On Error GoTo 0
|
||
End Sub
|
||
|
||
Private Sub RestoreAppStatus()
|
||
Application.Calculation = xlCalculationAutomatic
|
||
Application.ScreenUpdating = True
|
||
End Sub |