' ============================================================================== ' 模块: M09_BOMExtractor ' 职责: BOM自动提取系统的主流程编排和结果输出 ' ' 主要流程: ' 1. 读取输入工作表中的产品型号列表 ' 2. 打开BOM库.xlsx文件 ' 3. 对于每个产品型号: ' a. 解析型号,提取参数(M06_ModelParser) ' b. 遍历BOM库工作表,匹配物料(M07_BOMMatcher) ' c. 特殊处理"部件"物料(M08_ComponentProcessor) ' d. 验证部件组合规则 ' e. 生成输出行 ' 4. 将结果写入"BOM提取结果"工作表 ' 5. 生成错误报告 ' ' 输出格式: ' - 纵向展开格式,每个物料一行 ' - 列: 原始产品型号, azxs, bkxs, gclj, jycz, lcfw, fjgn, ' 物料类型, 物料名称, 物料编码, 物料数量, 提取备注 ' ============================================================================== Option Explicit ' 模块级变量 Private g_Logger As clsErrorLogger Private g_BOMWorkbook As Workbook ' ------------------------------------------------------------------------------ ' 主入口: 运行BOM提取流程 ' ' 输入: 无(从活动工作簿读取输入) ' ' 输出: ' String - 处理结果消息 ' ' 流程: ' 1. 初始化环境 ' 2. 读取输入产品型号 ' 3. 打开BOM库文件 ' 4. 处理每个产品型号 ' 5. 写入结果到工作表 ' 6. 生成错误报告 ' ' 示例调用: ' Dim result As String ' result = M09_BOMExtractor.RunBOMExtraction() ' MsgBox result ' ------------------------------------------------------------------------------ Public Function RunBOMExtraction() As String On Error GoTo MainErrorHandler ' 初始化 Set g_Logger = New clsErrorLogger Set g_BOMWorkbook = Nothing Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.DisplayAlerts = False ' 步骤1: 检查输入工作表 Dim wsInput As Worksheet Set wsInput = ThisWorkbook.Worksheets("产品型号") If wsInput Is Nothing Then RunBOMExtraction = "错误:未找到输入工作表。工作表名称应包含'" & INPUT_COL_MODEL & "'或'" & INPUT_COL_PRODUCT_MODEL & "'。" GoTo ExitHandler End If Application.StatusBar = "正在读取输入数据..." ' 步骤2: 读取输入产品型号 Dim inputModels As Variant inputModels = ReadInputModels(wsInput) If IsEmpty(inputModels) Then RunBOMExtraction = "错误:未找到产品型号数据。请检查工作表中是否有数据。" GoTo ExitHandler End If ' 步骤3: 打开BOM库文件 Application.StatusBar = "正在打开BOM库文件..." Set g_BOMWorkbook = OpenBOMLibrary() If g_BOMWorkbook Is Nothing Then RunBOMExtraction = "错误:无法打开BOM库文件。请确保[" & BOMLIB_FILENAME & "]与当前工作簿在同一目录下。" GoTo ExitHandler End If ' 初始化各模块 M06_ModelParser.InitModelParser g_Logger M07_BOMMatcher.InitBOMMatcher g_Logger M08_ComponentProcessor.InitComponentProcessor g_Logger ' 步骤4: 处理每个产品型号 Application.StatusBar = "正在处理产品型号..." Dim allResults As Collection Set allResults = New Collection Dim i As Long Dim totalModels As Long totalModels = UBound(inputModels, 1) For i = LBound(inputModels, 1) To UBound(inputModels, 1) ' 进度更新 If i Mod 10 = 0 Then Dim pct As Long pct = CLng((i / totalModels) * 100) Application.StatusBar = "正在处理: " & pct & "% | 型号: " & i & "/" & totalModels DoEvents End If ' 处理单个型号 Dim modelString As String modelString = CStr(inputModels(i, 1)) Dim modelResults As Collection Set modelResults = ProcessSingleModel(modelString, g_BOMWorkbook, g_Logger) ' 合并结果 Dim result As Variant For Each result In modelResults allResults.Add result Next result Next i ' 步骤5: 写入结果到工作表 Application.StatusBar = "正在写入结果..." Dim wsOutput As Worksheet Set wsOutput = WriteExtractionResults(allResults) ' 步骤6: 生成错误报告 If g_Logger.HasErrors Then g_Logger.PrintReport ActiveWorkbook End If ' 关闭BOM库文件 If Not g_BOMWorkbook Is Nothing Then g_BOMWorkbook.Close SaveChanges:=False Set g_BOMWorkbook = Nothing End If ' 构建返回消息 Dim successCount As Long Dim errorCount As Long successCount = 0 errorCount = 0 For Each result In allResults If Len(CStr(result(12))) = 0 Then ' 第12列是备注 successCount = successCount + 1 Else errorCount = errorCount + 1 End If Next result Dim msg As String msg = "BOM提取完成!" & vbCrLf & _ "处理型号数: " & totalModels & vbCrLf & _ "提取物料数: " & allResults.count & vbCrLf & _ "成功数: " & successCount & vbCrLf & _ "异常数: " & errorCount If g_Logger.HasErrors Then msg = msg & vbCrLf & vbCrLf & "发现错误,已生成错误报告工作表。" End If RunBOMExtraction = msg GoTo ExitHandler MainErrorHandler: RunBOMExtraction = "发生运行时错误: " & Err.Description & " (错误号: " & Err.Number & ")" ExitHandler: ' 清理 Application.StatusBar = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True ' 确保关闭BOM库文件 If Not g_BOMWorkbook Is Nothing Then On Error Resume Next g_BOMWorkbook.Close SaveChanges:=False On Error GoTo 0 Set g_BOMWorkbook = Nothing End If End Function ' ------------------------------------------------------------------------------ ' 获取输入工作表 ' ' 输入: 无(从活动工作簿查找) ' ' 输出: ' Worksheet - 包含产品型号列的工作表 ' ' 逻辑: ' - 优先查找名为"产品型号"的工作表 ' - 如果不存在,查找包含"型号"或"产品型号"列的工作表 ' ------------------------------------------------------------------------------ Private Function GetInputWorksheet() As Worksheet On Error Resume Next ' 方法1: 查找名为"产品型号"的工作表 Set GetInputWorksheet = ActiveWorkbook.Sheets(INPUT_COL_PRODUCT_MODEL) If Not GetInputWorksheet Is Nothing Then Exit Function End If ' 方法2: 查找包含"型号"列的工作表 Dim ws As Worksheet For Each ws In ActiveWorkbook.Worksheets Dim headerCell As Range Set headerCell = ws.Rows(1).Find(INPUT_COL_MODEL, LookAt:=xlWhole, MatchCase:=False) If Not headerCell Is Nothing Then Set GetInputWorksheet = ws Exit Function End If Set headerCell = ws.Rows(1).Find(INPUT_COL_PRODUCT_MODEL, LookAt:=xlWhole, MatchCase:=False) If Not headerCell Is Nothing Then Set GetInputWorksheet = ws Exit Function End If Next ws Set GetInputWorksheet = Nothing On Error GoTo 0 End Function ' ------------------------------------------------------------------------------ ' 读取输入产品型号 ' ' 输入: ' ws - 输入工作表 ' ' 输出: ' Variant - 二维数组,包含产品型号列表 ' ' 注意: ' - 自动查找"型号"或"产品型号"列 ' - 从第2行开始读取(第1行是表头) ' ------------------------------------------------------------------------------ Private Function ReadInputModels(ByVal ws As Worksheet) As Variant On Error GoTo ErrorHandler ' 查找型号列 Dim headerCell As Range Set headerCell = ws.Rows(1).Find(INPUT_COL_PRODUCT_MODEL, LookAt:=xlPart, MatchCase:=False) If headerCell Is Nothing Then Set headerCell = ws.Rows(1).Find(INPUT_COL_MODEL, LookAt:=xlPart, MatchCase:=False) End If If headerCell Is Nothing Then ReadInputModels = Empty Exit Function End If Dim colIdx As Long colIdx = headerCell.Column ' 查找最后一行 Dim lastRow As Long lastRow = ws.Cells(ws.Rows.count, colIdx).End(xlUp).row If lastRow < 2 Then ReadInputModels = Empty Exit Function End If ' 读取数据到数组 ReadInputModels = ws.Range(ws.Cells(2, colIdx), ws.Cells(lastRow, colIdx)).Value Exit Function ErrorHandler: ReadInputModels = Empty End Function ' ------------------------------------------------------------------------------ ' 处理单个产品型号 ' ' 输入: ' modelString - 产品型号字符串 ' bomWb - BOM库工作簿 ' logger - 错误记录器 ' ' 输出: ' Collection - 提取结果集合 ' 每个元素是一个数组,包含12列数据 ' ' 流程: ' 1. 解析型号,提取参数 ' 2. 匹配所有物料类型 ' 3. 验证部件组合 ' 4. 生成输出行 ' ------------------------------------------------------------------------------ Private Function ProcessSingleModel( _ ByVal modelString As String, _ ByVal bomWb As Workbook, _ ByVal logger As clsErrorLogger _ ) As Collection On Error GoTo ErrorHandler Dim results As Collection Set results = New Collection ' 步骤1: 解析型号 Dim params As Object Set params = M06_ModelParser.ParseProductModel(modelString) ' 检查解析是否成功 If params.count = 0 Then ' 解析失败,添加错误行 results.Add GenerateErrorRow(modelString, "型号解析失败:型号格式不正确或缺少必要字段") Set ProcessSingleModel = results Exit Function End If ' 步骤2: 匹配所有物料类型 Dim allMaterials As Collection Set allMaterials = MatchAllMaterialTypes(params, bomWb, logger) ' 步骤3: 验证部件组合 Dim validation As Object Set validation = M08_ComponentProcessor.ValidateComponentCombination(allMaterials) ' 步骤4: 生成输出行 Dim remarks As String remarks = "" If Not validation("valid") Then remarks = validation("message") End If Dim mat As Variant For Each mat In allMaterials Dim outputRow As Variant outputRow = GenerateMaterialRow(modelString, params, mat, remarks) results.Add outputRow Next mat ' 如果没有匹配到任何物料,添加错误行 If allMaterials.count = 0 Then results.Add GenerateErrorRow(modelString, "未匹配到任何物料") End If Set ProcessSingleModel = results Exit Function ErrorHandler: If Not logger Is Nothing Then logger.Record 0, "M09.ProcessSingleModel", "SystemError", _ "处理型号[" & modelString & "]失败: " & Err.Description, "" End If results.Add GenerateErrorRow(modelString, "系统错误: " & Err.Description) Set ProcessSingleModel = results End Function ' ------------------------------------------------------------------------------ ' 匹配所有物料类型 ' ' 输入: ' params - 参数字典 ' bomWb - BOM库工作簿 ' logger - 错误记录器 ' ' 输出: ' Collection - 所有匹配到的物料集合 ' ' 逻辑: ' - 遍历BOM库中的所有工作表 ' - 对每个工作表尝试匹配 ' - "部件"工作表特殊处理(调用M08_ComponentProcessor) ' - 其他工作表使用M07_BOMMatcher匹配 ' ------------------------------------------------------------------------------ Private Function MatchAllMaterialTypes( _ ByVal params As Object, _ ByVal bomWb As Workbook, _ ByVal logger As clsErrorLogger _ ) As Collection On Error GoTo ErrorHandler Dim allMaterials As Collection Set allMaterials = New Collection ' 遍历BOM库中的所有工作表 Dim ws As Worksheet For Each ws In bomWb.Worksheets Dim sheetName As String sheetName = ws.Name Debug.Print "=== 处理工作表: [" & sheetName & "] ===" ' "部件"工作表特殊处理 If sheetName = BOMLIB_SHEET_COMPONENT Then Debug.Print " -> 使用部件处理逻辑" Dim componentMaterials As Collection Set componentMaterials = M08_ComponentProcessor.ProcessComponentRecord( _ ws, params, logger) Debug.Print " -> 返回物料数: " & componentMaterials.count Dim compMat As Variant For Each compMat In componentMaterials Debug.Print " [" & compMat("materialType") & "] 名称=[" & compMat("materialName") & "] 编码=[" & compMat("materialCode") & "]" allMaterials.Add compMat Next compMat Else ' 其他工作表使用标准匹配逻辑 ' 匹配记录 Dim matchResult As Object Set matchResult = M07_BOMMatcher.MatchBOMRecord(ws, params) Debug.Print " -> 匹配结果: " & matchResult("success") & ", 行数: " & matchResult("rowCount") ' 如果匹配成功,提取物料信息 If matchResult("success") Then Dim rowNum As Long rowNum = matchResult("rowNums")(1) Debug.Print " -> 匹配行号: " & rowNum Dim headerMap As Object Set headerMap = M07_BOMMatcher.BuildWorksheetHeaderMap(ws) Debug.Print " -> 表头映射键数: " & headerMap.count Dim materialInfo As Object Set materialInfo = M07_BOMMatcher.ExtractMaterialInfo(ws, rowNum, headerMap) Debug.Print " -> 提取结果: 名称=[" & materialInfo("materialName") & "] 编码=[" & materialInfo("materialCode") & "] 数量=[" & materialInfo("materialQty") & "]" If Not materialInfo Is Nothing Then allMaterials.Add materialInfo Debug.Print " -> 已添加到物料集合" Else Debug.Print " -> ERROR: materialInfo为Nothing" End If Else ' 匹配失败,记录错误(但不中断处理) If matchResult("rowCount") = 0 Then logger.Record 0, "M09.MatchAllMaterialTypes", "BOMMatchError", _ sheetName & " " & matchResult("message"), "" Debug.Print " -> 未匹配到记录" End If End If End If Debug.Print "" Next ws Set MatchAllMaterialTypes = allMaterials Exit Function ErrorHandler: If Not logger Is Nothing Then logger.Record 0, "M09.MatchAllMaterialTypes", "SystemError", _ "匹配物料类型失败: " & Err.Description, "" End If Set MatchAllMaterialTypes = allMaterials End Function ' ------------------------------------------------------------------------------ ' 生成单行输出数据 ' ' 输入: ' modelString - 原始产品型号 ' params - 参数字典 ' material - 物料信息字典 ' remarks - 备注信息 ' ' 输出: ' Variant - 包含12列数据的数组 ' ' 列定义: ' 1: 原始产品型号 ' 2: azxs ' 3: bkxs ' 4: gclj ' 5: jycz ' 6: lcfw ' 7: fjgn ' 8: 物料类型 ' 9: 物料名称 ' 10: 物料编码 ' 11: 物料数量 ' 12: 提取备注 ' ------------------------------------------------------------------------------ Private Function GenerateMaterialRow( _ ByVal modelString As String, _ ByVal params As Object, _ ByVal material As Object, _ ByVal remarks As String _ ) As Variant Dim result(1 To 12) As Variant ' 第1列: 原始产品型号 result(1) = modelString ' 第2-7列: 参数值 result(2) = GetParamValue(params, "azxs") result(3) = GetParamValue(params, "bkxs") result(4) = GetParamValue(params, "gclj") result(5) = GetParamValue(params, "jycz") result(6) = GetParamValue(params, "lcfw") result(7) = GetParamValue(params, "fjgn") ' 第8-11列: 物料信息 result(8) = GetMaterialValue(material, "materialType") result(9) = GetMaterialValue(material, "materialName") result(10) = GetMaterialValue(material, "materialCode") result(11) = GetMaterialValue(material, "materialQty") ' 第12列: 备注 result(12) = remarks & " " & GetMaterialValue(material, "remarks") result(12) = Trim(result(12)) GenerateMaterialRow = result End Function ' ------------------------------------------------------------------------------ ' 生成错误行 ' ' 输入: ' modelString - 原始产品型号 ' errorMessage - 错误消息 ' ' 输出: ' Variant - 包含12列数据的数组(仅型号和备注有值) ' ------------------------------------------------------------------------------ Private Function GenerateErrorRow( _ ByVal modelString As String, _ ByVal errorMessage As String _ ) As Variant Dim result(1 To 12) As Variant Dim i As Long For i = 1 To 12 result(i) = "" Next i result(1) = modelString result(12) = "错误: " & errorMessage GenerateErrorRow = result End Function ' ------------------------------------------------------------------------------ ' 辅助函数: 从参数字典中获取值 ' ------------------------------------------------------------------------------ Private Function GetParamValue(ByVal params As Object, ByVal key As String) As Variant If params.Exists(key) Then GetParamValue = params(key) Else GetParamValue = "" End If End Function ' ------------------------------------------------------------------------------ ' 辅助函数: 从物料字典中获取值 ' ------------------------------------------------------------------------------ Private Function GetMaterialValue(ByVal material As Object, ByVal key As String) As Variant If material.Exists(key) Then GetMaterialValue = material(key) Else GetMaterialValue = "" End If End Function ' ------------------------------------------------------------------------------ ' 写入提取结果到工作表 ' ' 输入: ' results - 提取结果集合 ' ' 输出: ' Worksheet - 输出工作表 ' ' 逻辑: ' 1. 创建或清空"BOM提取结果"工作表 ' 2. 写入表头 ' 3. 批量写入数据 ' 4. 格式化工作表 ' ------------------------------------------------------------------------------ Private Function WriteExtractionResults(ByVal results As Collection) As Worksheet On Error GoTo ErrorHandler Dim ws As Worksheet ' 创建或获取工作表 On Error Resume Next Set ws = ThisWorkbook.Sheets(OUTPUT_SHEET_NAME) On Error GoTo ErrorHandler If ws Is Nothing Then Set ws = ThisWorkbook.Worksheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count)) ws.Name = OUTPUT_SHEET_NAME Else ws.Cells.Clear End If ' 写入表头 Dim headers As Variant headers = Array("原始产品型号", "azxs", "bkxs", "gclj", "jycz", "lcfw", "fjgn", _ "物料类型", "物料名称", "物料编码", "物料数量", "提取备注") Dim c As Long For c = 1 To 12 ws.Cells(1, c).Value = headers(c - 1) Next c ' 格式化表头 With ws.Range("A1:L1") .Font.Bold = True .Interior.Color = RGB(217, 217, 217) .HorizontalAlignment = xlCenter End With ' 写入数据 If results.count > 0 Then Dim outputArr() As Variant ReDim outputArr(1 To results.count, 1 To 12) Dim i As Long Dim result As Variant For i = 1 To results.count result = results(i) Dim j As Long For j = 1 To 12 outputArr(i, j) = result(j) Next j Next i ws.Range("A2").Resize(results.count, 12).Value = outputArr ' 格式化数据区域 With ws.Range("A2:L" & (results.count + 1)) .Borders.LineStyle = xlContinuous .Borders.Weight = xlThin End With ' 如果有错误备注,标红 For i = 1 To results.count If Len(CStr(outputArr(i, 12))) > 0 And InStr(CStr(outputArr(i, 12)), "错误") > 0 Then ws.Cells(i + 1, 12).Interior.Color = RGB(255, 200, 200) End If Next i End If ' 自动调整列宽 ws.Columns.AutoFit ' 冻结首行 ws.Activate ActiveWindow.FreezePanes = False ws.Rows(2).Select ActiveWindow.FreezePanes = True ws.Cells(1, 1).Select Set WriteExtractionResults = ws Exit Function ErrorHandler: Set WriteExtractionResults = Nothing End Function ' ------------------------------------------------------------------------------ ' 打开BOM库文件 ' ' 输入: 无(从当前工作簿目录查找) ' ' 输出: ' Workbook - BOM库工作簿 ' ' 逻辑: ' 1. 获取当前工作簿路径 ' 2. 构建BOM库文件路径 ' 3. 打开BOM库文件(只读模式) ' ------------------------------------------------------------------------------ Private Function OpenBOMLibrary() As Workbook On Error GoTo ErrorHandler ' 获取当前工作簿路径 Dim currentPath As String currentPath = ActiveWorkbook.Path ' 构建BOM库文件路径 Dim bomPath As String bomPath = currentPath & "\" & BOMLIB_FILENAME ' 检查文件是否存在 Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(bomPath) Then Set OpenBOMLibrary = Nothing Exit Function End If ' 打开BOM库文件(只读) Set OpenBOMLibrary = Workbooks.Open(bomPath, ReadOnly:=True) Exit Function ErrorHandler: Set OpenBOMLibrary = Nothing End Function