'===================================================================== ' 模块名: MainModule ' 功能: 主控模块,处理产品型号提取和BOM匹配的上层逻辑 '===================================================================== Option Explicit '===================================================================== ' 常量定义 '===================================================================== ' 提取条件配置(可灵活扩展) Private Const CONDITION_CONFIG = "azxs,安装形式|bkxs,表壳形式|gclj,过程连接|jycz,接液材质|lcfw,量程范围" '===================================================================== ' 过程: ProcessProductModels ' 功能: 批量处理产品型号并输出结果 ' 说明: 这是主入口程序 '===================================================================== Public Sub ProcessProductModels() On Error GoTo ErrorHandler Dim startTime As Double startTime = Timer ' 准备输入输出 Dim inputSheet As Worksheet Dim outputSheet As Worksheet Dim bomSheet As Worksheet ' 获取工作表 Set inputSheet = GetInputSheet() If inputSheet Is Nothing Then MsgBox "未找到输入工作表,请确保工作簿中有包含订单数据的工作表", vbCritical Exit Sub End If ' 获取BOM库工作表 Set bomSheet = GetBomSheet() If bomSheet Is Nothing Then MsgBox "未找到'平台配置清单'工作表,请确保BOM数据存在", vbCritical Exit Sub End If ' 创建或获取输出工作表 Set outputSheet = CreateOutputSheet() ' 初始化BOM提取器 Dim BomExtractor As BomExtractor Set BomExtractor = New BomExtractor BomExtractor.SetWorksheet bomSheet If Not BomExtractor.LoadBomData Then MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical Exit Sub End If ' 处理每个产品型号 Dim lastRow As Long lastRow = inputSheet.Cells(inputSheet.Rows.Count, 1).End(xlUp).row ' 写入输出表头 WriteOutputHeader outputSheet ' 收集所有输出数据 Dim outputData As collection Set outputData = New collection Dim i As Long Dim modelString As String Dim processedCount As Long processedCount = 0 ' 假设产品型号在第1列,从第2行开始 For i = 2 To lastRow modelString = Trim(inputSheet.Cells(i, 2).value) Dim componentPriority As String componentPriority = Trim(inputSheet.Cells(i, 5).value) ' E列:部件优先 If modelString <> "" Then ' 处理单个型号,收集数据 ProcessSingleModel modelString, componentPriority, BomExtractor, outputData processedCount = processedCount + 1 End If Next i ' 批量写入数据到工作表 If outputData.Count > 0 Then WriteBatchData outputSheet, outputData End If ' 格式化输出表 FormatOutputSheet outputSheet Dim elapsedTime As Double elapsedTime = Timer - startTime MsgBox "处理完成!" & vbCrLf & _ "处理型号数: " & processedCount & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation ' 激活输出表 outputSheet.Activate Exit Sub ErrorHandler: MsgBox "处理异常: " & Err.description, vbCritical End Sub '===================================================================== ' 过程: ProcessSingleModel ' 功能: 处理单个产品型号,将数据添加到输出集合 ' 参数: modelString - 产品型号字符串 ' componentPriority - 部件优先标志("是"或"否") ' bomExtractor - BOM提取器对象 ' outputData - 输出数据集合 '===================================================================== Private Sub ProcessSingleModel(modelString As String, _ componentPriority As String, _ BomExtractor As BomExtractor, _ outputData As collection) On Error Resume Next ' 根据部件优先设置排除类别 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 parser As ProductModelParser Set parser = New ProductModelParser Dim extractNote As String extractNote = "" If Not parser.Parse(modelString) Then ' 解析失败 extractNote = "解析失败: " & parser.ErrorMessage outputData.Add CreateOutputRowArray(modelString, "", parser.Conditions, extractNote, Nothing) Exit Sub End If ' 提取BOM Dim matchedItems As collection Set matchedItems = BomExtractor.ExtractBom(parser.Conditions) ' 获取错误信息 Dim bomErrors As String bomErrors = BomExtractor.GetErrorSummary If bomErrors <> "" Then extractNote = bomErrors End If ' 输出结果 If matchedItems.Count = 0 Then ' 没有匹配项 If extractNote = "" Then extractNote = "未匹配到任何物料" End If outputData.Add CreateOutputRowArray(modelString, parser.HeaderModel, parser.Conditions, extractNote, Nothing) Else ' 输出每个匹配的物料 Dim item As BomItem Dim isFirst As Boolean isFirst = True For Each item In matchedItems Dim itemNote As String itemNote = extractNote ' 添加物料特定的错误 If item.MatchError <> "" Then If itemNote <> "" Then itemNote = itemNote & "; " itemNote = itemNote & item.MatchError End If If isFirst Then outputData.Add CreateOutputRowArray(modelString, parser.HeaderModel, parser.Conditions, itemNote, item) isFirst = False Else outputData.Add CreateOutputRowArray("", "", parser.Conditions, itemNote, item) End If Next item End If End Sub '===================================================================== ' 过程: WriteOutputHeader ' 功能: 写入输出表头 ' 参数: ws - 工作表对象 '===================================================================== 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 ' 写入条件字段表头 Dim Conditions() As String Dim labels() As String GetConditionConfig Conditions, labels Dim i As Long For i = LBound(Conditions) To UBound(Conditions) ws.Cells(1, col).value = labels(i) col = col + 1 Next i ' BOM字段表头 ws.Cells(1, col).value = "行号": col = 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 ws.Cells(1, col).value = "数量": col = col + 1 ws.Cells(1, col).value = "类别": col = col + 1 ws.Cells(1, col).value = "66代码": col = col + 1 ws.Cells(1, col).value = "提取备注": col = col + 1 End Sub '===================================================================== ' 函数: CreateOutputRowArray ' 功能: 创建输出行数据的数组 ' 参数: FullModel - 完整型号 ' HeaderModel - 表头型号 ' Conditions - 条件字典 ' note - 备注 ' item - BOM项(可为Nothing) ' 返回: Variant() - 行数据数组 '===================================================================== Private Function CreateOutputRowArray(FullModel As String, _ HeaderModel As String, _ Conditions As Object, _ note As String, _ item As BomItem) As Variant() ' 获取条件配置 Dim condNames() As String Dim labels() As String GetConditionConfig condNames, labels ' 计算总列数:2 + 条件数 + 8 Dim totalCols As Long totalCols = 2 + (UBound(condNames) - LBound(condNames) + 1) + 8 ' 创建数组 ReDim rowData(1 To totalCols) As Variant Dim col As Long col = 1 ' 产品型号和表头型号 rowData(col) = FullModel: col = col + 1 rowData(col) = HeaderModel: col = col + 1 ' 写入条件值 Dim i As Long For i = LBound(condNames) To UBound(condNames) If Conditions.Exists(condNames(i)) Then rowData(col) = Conditions(condNames(i)) Else rowData(col) = "" End If col = col + 1 Next i ' 写入BOM数据 If Not item Is Nothing Then rowData(col) = item.RowNumber: col = col + 1 rowData(col) = item.Module: col = col + 1 rowData(col) = item.code: col = col + 1 rowData(col) = item.Name: col = col + 1 rowData(col) = item.quantity: col = col + 1 rowData(col) = item.category: col = col + 1 rowData(col) = item.Code66: col = col + 1 Else ' 跳过BOM字段 col = col + 7 End If ' 备注 rowData(col) = note CreateOutputRowArray = rowData End Function '===================================================================== ' 过程: WriteBatchData ' 功能: 批量写入数据到工作表 ' 参数: ws - 工作表对象 ' outputData - 输出数据集合 '===================================================================== Private Sub WriteBatchData(ws As Worksheet, outputData As collection) ' 如果没有数据,直接返回 If outputData.Count = 0 Then Exit Sub End If ' 获取第一行数据来确定列数 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 Dim 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 ' 一次性写入工作表(从第2行开始) ws.Range("A2").Resize(rowCount, colCount).value = resultData End Sub '===================================================================== ' 过程: GetConditionConfig ' 功能: 获取条件配置 ' 参数: outNames - 输出条件名称数组 ' outLabels - 输出条件标签数组 '===================================================================== Private Sub GetConditionConfig(ByRef outNames() As String, ByRef outLabels() As String) Dim configs() As String configs = Split(CONDITION_CONFIG, "|") ReDim outNames(LBound(configs) To UBound(configs)) ReDim outLabels(LBound(configs) To UBound(configs)) Dim i As Long Dim parts() As String For i = LBound(configs) To UBound(configs) parts = Split(configs(i), ",") outNames(i) = Trim(parts(0)) outLabels(i) = Trim(parts(1)) Next i End Sub '===================================================================== ' 函数: GetInputSheet ' 功能: 获取输入工作表 ' 返回: Worksheet - 输入工作表对象 '===================================================================== Private Function GetInputSheet() As Worksheet ' 这里假设输入数据在当前活动工作表或名为"订单"的工作表 On Error Resume Next Set GetInputSheet = ThisWorkbook.Worksheets("产品订单") If GetInputSheet Is Nothing Then Set GetInputSheet = ActiveSheet End If On Error GoTo 0 End Function '===================================================================== ' 函数: GetBomSheet ' 功能: 获取BOM工作表 ' 返回: Worksheet - BOM工作表对象 '===================================================================== Private Function GetBomSheet() As Worksheet On Error Resume Next Set GetBomSheet = ThisWorkbook.Worksheets("平台配置清单") On Error GoTo 0 End Function '===================================================================== ' 函数: CreateOutputSheet ' 功能: 创建或获取输出工作表 ' 返回: Worksheet - 输出工作表对象 '===================================================================== Private Function CreateOutputSheet() As Worksheet Dim wsName As String wsName = "BOM提取结果" On Error Resume Next Set CreateOutputSheet = ThisWorkbook.Worksheets(wsName) On Error GoTo 0 If CreateOutputSheet Is Nothing Then Set CreateOutputSheet = ThisWorkbook.Worksheets.Add CreateOutputSheet.Name = wsName Else ' 清空现有数据 CreateOutputSheet.Cells.Clear End If End Function '===================================================================== ' 过程: FormatOutputSheet ' 功能: 格式化输出工作表 ' 参数: ws - 工作表对象 '===================================================================== Private Sub FormatOutputSheet(ws As Worksheet) On Error Resume Next ' 设置表头格式 With ws.Rows(1) .Font.Bold = True .Interior.Color = RGB(217, 217, 217) .HorizontalAlignment = xlCenter End With ' ' 自动调整列宽 ' ws.Columns.AutoFit ' ' ' 冻结首行 ' ws.Rows(2).Select ' 'ActiveWindow.FreezePanes = True ' ws.Cells(1, 1).Select On Error GoTo 0 End Sub