diff --git a/VBA/ClassModules/clsBOMManager.cls b/VBA/ClassModules/clsBOMManager.cls index 8a0a6aa..cbea360 100644 --- a/VBA/ClassModules/clsBOMManager.cls +++ b/VBA/ClassModules/clsBOMManager.cls @@ -424,7 +424,7 @@ Public Function GetMaterialsByModel(modelStr As String, _ ' ======================================== Dim parser As New clsModelParser If Not parser.ParseModel(modelStr) Then - Debug.Print "型号解析失败: " & parser.ErrorMessage + 'Debug.Print "型号解析失败: " & parser.ErrorMessage Set GetMaterialsByModel = result Exit Function End If @@ -434,13 +434,13 @@ Public Function GetMaterialsByModel(modelStr As String, _ Set conditions = extractor.ExtractConditions(parser) ' 调试输出 - Debug.Print "【型号】: " & modelStr - Debug.Print "【提取的条件】:" + 'Debug.Print "【型号】: " & modelStr + 'Debug.Print "【提取的条件】:" Dim key As Variant For Each key In conditions.Keys - Debug.Print " " & key & " = " & conditions(key) + 'Debug.Print " " & key & " = " & conditions(key) Next key - Debug.Print "" + 'Debug.Print "" ' ======================================== ' 第2步: 按类别筛选物料（根据参数决定是否自动降级到子类别） @@ -454,11 +454,11 @@ Public Function GetMaterialsByModel(modelStr As String, _ totalMatchCount = 0 If autoFallback Then - Debug.Print "【降级模式】启用自动降级到子类别" + 'Debug.Print "【降级模式】启用自动降级到子类别" Else - Debug.Print "【降级模式】禁用自动降级，仅查找当前类别" + 'Debug.Print "【降级模式】禁用自动降级，仅查找当前类别" End If - Debug.Print "" + 'Debug.Print "" If categoryName <> "" Then ' ======================================== @@ -496,8 +496,8 @@ Public Function GetMaterialsByModel(modelStr As String, _ Next j End If - Debug.Print "共匹配 " & totalMatchCount & " 个物料" - Debug.Print String(60, "=") + 'Debug.Print "共匹配 " & totalMatchCount & " 个物料" + 'Debug.Print String(60, "=") Set GetMaterialsByModel = result End Function @@ -557,7 +557,7 @@ Private Function FilterCategoryWithSubcategories(ByVal cat As clsCategory, _ matchCount = matchCount + 1 ' 调试输出 - Debug.Print "【匹配】" & cat.categoryName & " > " & _ + 'Debug.Print "【匹配】" & cat.categoryName & " > " & _ mat.code & " - " & mat.Name & _ " | 条件: " & IIf(mat.Condition = "", "(无)", mat.Condition) End If @@ -567,7 +567,7 @@ Private Function FilterCategoryWithSubcategories(ByVal cat As clsCategory, _ ' 第二阶段: 如果当前类别无匹配且允许降级，检查子类别 ' ======================================== If matchCount = 0 And cat.HasSubCategories And autoFallback Then - Debug.Print "【降级】类别 """ & cat.categoryName & """ 无匹配物料，降级到子类别查找..." + 'Debug.Print "【降级】类别 """ & cat.categoryName & """ 无匹配物料，降级到子类别查找..." ' 递归处理所有子类别 Dim subCat As clsCategory @@ -586,9 +586,9 @@ Private Function FilterCategoryWithSubcategories(ByVal cat As clsCategory, _ Next k Next j ElseIf matchCount = 0 And cat.HasSubCategories And Not autoFallback Then - Debug.Print "【跳过】类别 """ & cat.categoryName & """ 无匹配物料，但降级已禁用，不查找子类别" + 'Debug.Print "【跳过】类别 """ & cat.categoryName & """ 无匹配物料，但降级已禁用，不查找子类别" ElseIf matchCount > 0 Then - Debug.Print "【成功】类别 """ & cat.categoryName & """ 匹配 " & matchCount & " 个物料" + 'Debug.Print "【成功】类别 """ & cat.categoryName & """ 匹配 " & matchCount & " 个物料" End If Set FilterCategoryWithSubcategories = result @@ -712,7 +712,7 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection Dim allMaterials As New collection Dim allMissingCats As New collection ' 用于存储所有缺失的类别 Dim isComplete As Boolean - + ' 解析型号并提取条件 Dim parser As New clsModelParser If Not parser.ParseModel(modelStr) Then @@ -724,26 +724,26 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection Set GetValidMaterialsByModel = result Exit Function End If - + Dim extractor As New clsConditionExtractor Dim conditions As Object Set conditions = extractor.ExtractConditions(parser) - + ' 条件匹配器 Dim matcher As New clsConditionMatcher - + ' 遍历所有根类别,检查完整性 isComplete = True - + Dim rootCat As clsCategory Dim i As Long - For i = 1 To rootCategories.count + For i = 1 To rootCategories.Count Set rootCat = rootCategories(i) - + ' 检查该类别及其子类别的完整性 Dim catResult As Object Set catResult = CheckCategoryCompleteness(rootCat, matcher, conditions) - + ' 1. 合并匹配到的物料 Dim mat As clsMaterialItem Dim matCollection As collection @@ -751,7 +751,7 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection For Each mat In matCollection allMaterials.Add mat Next mat - + ' 2. 合并缺失的类别 (新增) Dim missingCollection As collection Set missingCollection = catResult("Missing") @@ -759,18 +759,18 @@ Public Function GetValidMaterialsByModel(modelStr As String) As collection For Each missingCatName In missingCollection allMissingCats.Add missingCatName Next missingCatName - + ' 3. 检查完整性状态 If Not catResult("IsComplete") Then isComplete = False End If Next i - + ' 返回结果 result.Add allMaterials, "Materials" result.Add isComplete, "IsComplete" result.Add allMissingCats, "MissingCategories" ' 新增返回项 - + Set GetValidMaterialsByModel = result End Function @@ -803,25 +803,25 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ conditions As Object) As Object Dim result As Object Set result = CreateObject("Scripting.Dictionary") - + Dim materials As New collection Dim missingCats As New collection ' 本层级及子层级缺失的类别 Dim isComplete As Boolean - + ' 首先在当前类别查找匹配的物料 Dim mat As clsMaterialItem Dim matchCount As Long matchCount = 0 - + Dim i As Long - For i = 1 To cat.materials.count + For i = 1 To cat.materials.Count Set mat = cat.materials(i) If matcher.IsMatch(mat.Condition, conditions) Then materials.Add mat matchCount = matchCount + 1 End If Next i - + ' 判断完整性 If Not cat.HasSubCategories Then ' ======================================== @@ -847,28 +847,28 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ ' 不需要检查子类别了，missingCats 保持为空 ElseIf matchCount = 0 Then ' 父类别无匹配物料, 必须降级检查所有子类别 - + ' 清空当前物料集合(确保没东西), 准备收集子类别结果 Set materials = New collection isComplete = True ' 先假设完整, 若任一子类别不完整则置错 - + Dim subCat As clsCategory Dim j As Long - For j = 1 To cat.SubCategories.count + For j = 1 To cat.SubCategories.Count Set subCat = cat.SubCategories(j) - + ' 递归检查子类别 Dim subResult As Object Set subResult = CheckCategoryCompleteness(subCat, matcher, conditions) - + ' a) 合并子类别物料 Dim subMaterials As collection Set subMaterials = subResult("Materials") Dim k As Long - For k = 1 To subMaterials.count + For k = 1 To subMaterials.Count materials.Add subMaterials(k) Next k - + ' b) 合并子类别缺失列表 (关键步骤) Dim subMissing As collection Set subMissing = subResult("Missing") @@ -876,7 +876,7 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ For Each item In subMissing missingCats.Add item Next item - + ' c) 更新完整性状态 If Not subResult("IsComplete") Then isComplete = False @@ -887,10 +887,10 @@ Private Function CheckCategoryCompleteness(cat As clsCategory, _ isComplete = False End If End If - + ' 封装返回结果 Set result("Materials") = materials result("IsComplete") = isComplete Set result("Missing") = missingCats Set CheckCategoryCompleteness = result -End Function +End Function \ No newline at end of file diff --git a/VBA/ClassModules/clsMaterialWithFlag.cls b/VBA/ClassModules/clsMaterialWithFlag.cls new file mode 100644 index 0000000..c6940b4 --- /dev/null +++ b/VBA/ClassModules/clsMaterialWithFlag.cls @@ -0,0 +1,34 @@ +' ======================================== +' 类模块: clsMaterialWithFlag +' 用途: 包装物料对象及其匹配状态标志 +' ======================================== +Option Explicit + +Private mMaterial As clsMaterialItem ' 物料对象 +Private mIsComplete As Boolean ' 是否完整匹配 + +' ======================================== +' 属性: Material +' 说明: 获取或设置物料对象 +' ======================================== +Public Property Get Material() As clsMaterialItem + Set Material = mMaterial +End Property + +Public Property Set Material(ByVal value As clsMaterialItem) + Set mMaterial = value +End Property + +' ======================================== +' 属性: IsComplete +' 说明: 获取或设置是否完整匹配 +' True: 该物料属于完整的物料清单 +' False: 该物料属于不完整的物料清单（某些类别缺失物料） +' ======================================== +Public Property Get isComplete() As Boolean + isComplete = mIsComplete +End Property + +Public Property Let isComplete(ByVal value As Boolean) + mIsComplete = value +End Property \ No newline at end of file diff --git a/VBA/DocumentModules/Sheet1.cls b/VBA/DocumentModules/Sheet1.cls deleted file mode 100644 index e69de29..0000000 diff --git a/VBA/DocumentModules/Sheet2.cls b/VBA/DocumentModules/Sheet2.cls deleted file mode 100644 index e69de29..0000000 diff --git a/VBA/DocumentModules/Sheet3.cls b/VBA/DocumentModules/Sheet3.cls deleted file mode 100644 index e69de29..0000000 diff --git a/VBA/DocumentModules/Sheet4.cls b/VBA/DocumentModules/Sheet4.cls deleted file mode 100644 index e69de29..0000000 diff --git a/VBA/DocumentModules/Sheet6.cls b/VBA/DocumentModules/Sheet6.cls deleted file mode 100644 index e69de29..0000000 diff --git a/VBA/DocumentModules/ThisWorkbook.cls b/VBA/DocumentModules/ThisWorkbook.cls deleted file mode 100644 index e69de29..0000000 diff --git a/VBA/Modules/modModelParserExamples.bas b/VBA/Modules/modModelParserExamples.bas index bb360e5..c4916a3 100644 --- a/VBA/Modules/modModelParserExamples.bas +++ b/VBA/Modules/modModelParserExamples.bas @@ -87,7 +87,7 @@ Sub Example1_GeneratePickingListByModel() wsPickList.Cells(row, 3).value = mat.Name wsPickList.Cells(row, 4).value = mat.Quantity wsPickList.Cells(row, 5).value = IIf(mat.Condition = "", "(无条件)", mat.Condition) - wsPickList.Cells(row, 6).value = "✓" + wsPickList.Cells(row, 6).value = "??" row = row + 1 Next j Next i @@ -486,9 +486,9 @@ Sub Example6_CompareAutoFallback() wsCompare.Cells(row, 1).value = "说明:" wsCompare.Cells(row, 1).Font.Bold = True row = row + 1 - wsCompare.Cells(row, 1).value = "• autoFallback=True (默认): 当""部件""类别无匹配物料时,自动降级到子类别""接头""、""弹性元件""等查找" + wsCompare.Cells(row, 1).value = "?? autoFallback=True (默认): 当""部件""类别无匹配物料时,自动降级到子类别""接头""、""弹性元件""等查找" row = row + 1 - wsCompare.Cells(row, 1).value = "• autoFallback=False: 仅在""部件""类别查找,即使有子类别也不降级,可能返回空集合" + wsCompare.Cells(row, 1).value = "?? autoFallback=False: 仅在""部件""类别查找,即使有子类别也不降级,可能返回空集合" ' 格式化 wsCompare.Columns("A:E").AutoFit @@ -554,7 +554,7 @@ Sub Example7_TestGetValidMaterialsByModel() Dim materials As collection Dim missingCats As collection Dim isComplete As Boolean - + Set materials = result("Materials") Set missingCats = result("MissingCategories") ' 直接获取缺失列表 isComplete = result("IsComplete") @@ -570,7 +570,7 @@ Sub Example7_TestGetValidMaterialsByModel() row = row + 1 wsTest.Cells(row, 1).value = "完整性:" - wsTest.Cells(row, 2).value = IIf(isComplete, "✓ 完整", "✕ 不完整") + wsTest.Cells(row, 2).value = IIf(isComplete, "?? 完整", "?? 不完整") If isComplete Then wsTest.Cells(row, 2).Font.Color = RGB(0, 128, 0) Else @@ -578,12 +578,12 @@ Sub Example7_TestGetValidMaterialsByModel() End If wsTest.Cells(row, 2).Font.Bold = True row = row + 1 - + ' 3. 打印匹配到的物料 wsTest.Cells(row, 1).value = "【已匹配物料】" wsTest.Cells(row, 1).Font.Bold = True row = row + 1 - + wsTest.Cells(row, 1).value = "类别" wsTest.Cells(row, 2).value = "代号" wsTest.Cells(row, 3).value = "名称" @@ -591,9 +591,9 @@ Sub Example7_TestGetValidMaterialsByModel() wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 4)).Font.Bold = True wsTest.Range(wsTest.Cells(row, 1), wsTest.Cells(row, 4)).Interior.Color = RGB(220, 220, 220) row = row + 1 - + Dim mat As clsMaterialItem - If materials.count > 0 Then + If materials.Count > 0 Then For Each mat In materials wsTest.Cells(row, 1).value = mat.Category wsTest.Cells(row, 2).value = mat.code @@ -605,18 +605,18 @@ Sub Example7_TestGetValidMaterialsByModel() wsTest.Cells(row, 1).value = "(无)" row = row + 1 End If - + ' 4. 打印缺失的类别 (新增核心功能) - If missingCats.count > 0 Then + If missingCats.Count > 0 Then row = row + 1 wsTest.Cells(row, 1).value = "【缺失类别】" wsTest.Cells(row, 1).Font.Color = RGB(255, 0, 0) wsTest.Cells(row, 1).Font.Bold = True row = row + 1 - + Dim catName As Variant For Each catName In missingCats - wsTest.Cells(row, 1).value = "❌ " & catName + wsTest.Cells(row, 1).value = "?? " & catName wsTest.Cells(row, 1).Font.Color = RGB(255, 0, 0) wsTest.Cells(row, 2).value = "未找到匹配物料" row = row + 1 @@ -631,4 +631,360 @@ Sub Example7_TestGetValidMaterialsByModel() wsTest.Columns("A:D").AutoFit MsgBox "测试完成！", vbInformation +End Sub + +' ======================================== +' 示例8: 批量处理产品订单，生成物料清单 +' ======================================== +Sub Example8_BatchProcessOrders() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet + Dim wsPlatform As Worksheet + Dim wsOrders As Worksheet + Dim wsOutput As Worksheet + + ' 加载配置 + On Error Resume Next + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + Set wsOrders = ThisWorkbook.Worksheets("产品订单") + + If wsConfig Is Nothing Then + MsgBox "找不到工作表: 领料配置", vbCritical + Exit Sub + End If + If wsPlatform Is Nothing Then + MsgBox "找不到工作表: 平台配置清单", vbCritical + Exit Sub + End If + If wsOrders Is Nothing Then + MsgBox "找不到工作表: 产品订单", vbCritical + Exit Sub + End If + On Error GoTo 0 + + bomMgr.LoadData wsConfig, wsPlatform + + ' 读取订单数据 + Dim lastRow As Long + lastRow = wsOrders.Cells(wsOrders.Rows.Count, "A").End(xlUp).row + + If lastRow < 2 Then + MsgBox "产品订单工作表没有数据！" & vbCrLf & _ + "请确保第一行是表头，从第二行开始是数据。", vbExclamation + Exit Sub + End If + + ' 使用 Collection 收集所有输出行 + Dim outputData As collection + Set outputData = New collection + + ' 添加表头 + outputData.Add Array("来源单号", "产品型号", "物料代码", "物料名称", "数量", "选择条件", "类别") + + ' 遍历每个订单，收集数据 + Dim i As Long + Dim orderNo As String + Dim modelStr As String + Dim materials As collection + Dim mat As clsMaterialItem + Dim processedCount As Long + Dim materialCount As Long + + processedCount = 0 + materialCount = 0 + + For i = 2 To lastRow + orderNo = Trim(wsOrders.Cells(i, 1).value) + modelStr = Trim(wsOrders.Cells(i, 2).value) + + ' 跳过空行 + If orderNo = "" And modelStr = "" Then + GoTo ContinueLoop + End If + + ' 验证必填字段 + If orderNo = "" Then + orderNo = "(未填写)" + End If + + If modelStr = "" Then + outputData.Add Array(orderNo, "(空白型号)", "错误", "产品型号为空", "", "", "") + GoTo ContinueLoop + End If + + ' 获取物料 + On Error Resume Next + Set materials = bomMgr.GetMaterialsByModel(modelStr, "", True) + On Error GoTo 0 + + If materials Is Nothing Then + outputData.Add Array(orderNo, modelStr, "错误", "无法解析型号或获取物料", "", "", "") + GoTo ContinueLoop + End If + + ' 收集物料明细 + If materials.Count > 0 Then + For Each mat In materials + outputData.Add Array( _ + orderNo, _ + modelStr, _ + mat.code, _ + mat.Name, _ + mat.Quantity, _ + IIf(mat.Condition = "", "(无条件)", mat.Condition), _ + mat.Category _ + ) + materialCount = materialCount + 1 + Next mat + Else + outputData.Add Array(orderNo, modelStr, "(无)", "未找到任何匹配物料", "", "", "") + End If + + processedCount = processedCount + 1 + +ContinueLoop: + Next i + +' 创建输出工作表 + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("产品订单物料清单").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsOutput = ThisWorkbook.Worksheets.Add + wsOutput.Name = "产品订单物料清单" + + ' 批量写入数据到工作表 + If outputData.Count > 0 Then + Dim dataArray() As Variant + ReDim dataArray(1 To outputData.Count, 1 To 7) + + Dim j As Long + Dim rowArr As Variant + For j = 1 To outputData.Count + rowArr = outputData(j) + dataArray(j, 1) = rowArr(0) + dataArray(j, 2) = rowArr(1) + dataArray(j, 3) = rowArr(2) ' 这里是物料代码 + dataArray(j, 4) = rowArr(3) + dataArray(j, 5) = rowArr(4) + dataArray(j, 6) = rowArr(5) + dataArray(j, 7) = rowArr(6) + Next j + + ' --- 关键修改：在写入数据前，将 C 列设置为文本格式 --- + ' 使用 NumberFormat = "@" 强制指定为文本格式 + wsOutput.Columns("C").NumberFormat = "@" + + ' 一次性写入 + wsOutput.Range("A1").Resize(outputData.Count, 7).value = dataArray + + ' 格式化表头 + With wsOutput.Range("A1:G1") + .Font.Bold = True + .Interior.Color = RGB(200, 200, 200) + ' 表头所在的 C1 单元格通常可以改回常规格式，或者保持文本格式也不影响 + .NumberFormat = "General" + End With + End If + + ' 格式化 + wsOutput.Columns("A:G").AutoFit + + ' 显示统计信息 + Dim msg As String + msg = "批量处理完成！" & vbCrLf & vbCrLf + msg = msg & "处理订单数: " & processedCount & vbCrLf + msg = msg & "生成物料记录: " & materialCount & " 条" & vbCrLf & vbCrLf + msg = msg & "请查看工作表: 产品订单物料清单" + + MsgBox msg, vbInformation +End Sub + +' ======================================== +' 示例9: 批量处理订单 - 带完整性检查与模块数量校验 +' 功能： +' 1. 提取型号条件 +' 2. 校验模块数量（如果是3个模块则报错） +' 3. 校验类别完整性（如果缺失类别则报错） +' 4. 生成BOM清单 +' ======================================== +Sub Example9_BatchProcessOrders_WithCheck() + Dim bomMgr As New clsBOMManager + Dim wsConfig As Worksheet, wsPlatform As Worksheet, wsOrders As Worksheet, wsOutput As Worksheet + Dim parser As clsModelParser + Dim extractor As clsConditionExtractor + + ' 1. 初始化与加载数据 + On Error Resume Next + Set wsConfig = ThisWorkbook.Worksheets("领料配置") + Set wsPlatform = ThisWorkbook.Worksheets("平台配置清单") + Set wsOrders = ThisWorkbook.Worksheets("产品订单") + On Error GoTo 0 + + If wsConfig Is Nothing Or wsPlatform Is Nothing Or wsOrders Is Nothing Then + MsgBox "错误：缺少必要的工作表 (领料配置/平台配置清单/产品订单)", vbCritical + Exit Sub + End If + + bomMgr.LoadData wsConfig, wsPlatform + + ' 2. 准备输出容器 + Dim outputData As collection + Set outputData = New collection + ' 添加表头 + outputData.Add Array("来源单号", "产品型号", "物料代码", "物料名称", "数量", "选择条件", "提取的物料选择条件", "类别", "备注") + + ' 3. 遍历订单 + Dim lastRow As Long + lastRow = wsOrders.Cells(wsOrders.Rows.Count, "A").End(xlUp).row + + Dim i As Long + Dim orderNo As String, modelStr As String + Dim extractedCondStr As String + Dim parts() As String + Dim moduleCount As Integer + Dim result As collection, materials As collection, missingCats As collection + Dim isComplete As Boolean + Dim mat As clsMaterialItem + + ' 辅助变量 + Dim key As Variant + Dim missingStr As String + Dim catItem As Variant + + For i = 2 To lastRow + orderNo = Trim(wsOrders.Cells(i, 1).value) + modelStr = Trim(wsOrders.Cells(i, 2).value) + + If orderNo = "" And modelStr = "" Then GoTo NextOrder + If orderNo = "" Then orderNo = "(未填写)" + + ' ------------------------------------------------- + ' 步骤 A: 解析型号并提取条件字符串 (用于输出列) + ' ------------------------------------------------- + extractedCondStr = "" + Set parser = New clsModelParser + Set extractor = New clsConditionExtractor + + If parser.ParseModel(modelStr) Then + Dim conditions As Object + Set conditions = extractor.ExtractConditions(parser) + For Each key In conditions.Keys + extractedCondStr = extractedCondStr & key & "=" & conditions(key) & "; " + Next key + If Len(extractedCondStr) > 2 Then extractedCondStr = Left(extractedCondStr, Len(extractedCondStr) - 2) + Else + ' 解析失败直接输出错误 + outputData.Add Array(orderNo, modelStr, "", "", "", "", "", "", "解析失败: " & parser.ErrorMessage) + GoTo NextOrder + End If + + ' ------------------------------------------------- + ' 步骤 B: 校验模块数量 (表头 | 表盘 | 附件 | 法兰) + ' ------------------------------------------------- + ' Split返回0-based数组。0=1个模块, 1=2个模块, 2=3个模块 + parts = Split(modelStr, "|") + moduleCount = UBound(parts) + 1 + + ' 规则：如果出现三个模块，不输出物料，备注填入原因 + If moduleCount = 3 Then + outputData.Add Array(orderNo, modelStr, "", "", "", "", extractedCondStr, "", "包含其它模块") + GoTo NextOrder + End If + + ' ------------------------------------------------- + ' 步骤 C: 获取物料并校验类别完整性 + ' ------------------------------------------------- + Set result = bomMgr.GetValidMaterialsByModel(modelStr) + + isComplete = result("IsComplete") + Set materials = result("Materials") + Set missingCats = result("MissingCategories") + + ' 规则：如果类别缺失，不输出物料，备注填入缺失的类别 + If Not isComplete Then + missingStr = "" + For Each catItem In missingCats + missingStr = missingStr & catItem & ", " + Next catItem + + If Len(missingStr) > 2 Then missingStr = Left(missingStr, Len(missingStr) - 2) + If missingStr = "" Then missingStr = "完整性校验未通过(未知原因)" ' 防御性编程 + + outputData.Add Array(orderNo, modelStr, "", "", "", "", extractedCondStr, "", "类别缺失: " & missingStr) + GoTo NextOrder + End If + + ' ------------------------------------------------- + ' 步骤 D: 正常输出物料 + ' ------------------------------------------------- + If materials.Count > 0 Then + For Each mat In materials + outputData.Add Array( _ + orderNo, _ + modelStr, _ + mat.code, _ + mat.Name, _ + mat.Quantity, _ + IIf(mat.Condition = "", "(无条件)", mat.Condition), _ + extractedCondStr, _ + mat.Category, _ + "" _ + ) + Next mat + Else + outputData.Add Array(orderNo, modelStr, "", "", "", "", extractedCondStr, "", "无匹配物料") + End If + +NextOrder: + Next i + + ' 4. 写入结果到新工作表 + On Error Resume Next + Application.DisplayAlerts = False + ThisWorkbook.Worksheets("订单BOM_校验版").Delete + Application.DisplayAlerts = True + On Error GoTo 0 + + Set wsOutput = ThisWorkbook.Worksheets.Add + wsOutput.Name = "订单BOM_校验版" + + If outputData.Count > 0 Then + ' 转换为二维数组以提高写入速度 + Dim dataArr() As Variant + ReDim dataArr(1 To outputData.Count, 1 To 9) + + Dim r As Long, c As Long + Dim rowItem As Variant + + For r = 1 To outputData.Count + rowItem = outputData(r) + For c = 0 To 8 + dataArr(r, c + 1) = rowItem(c) + Next c + Next r + + ' 设置物料代码列(C列)为文本格式 + wsOutput.Columns("C:C").NumberFormat = "@" + + ' 写入数据 + wsOutput.Range("A1").Resize(outputData.Count, 9).value = dataArr + + ' 格式化美化 + With wsOutput.Range("A1:I1") + .Font.Bold = True + .Interior.Color = RGB(220, 230, 241) + .HorizontalAlignment = xlCenter + End With + + wsOutput.Columns("A:I").AutoFit + ' 备注列标红显示 + wsOutput.Columns("I:I").Font.Color = RGB(255, 0, 0) + wsOutput.Cells(1, 9).Font.Color = RGB(0, 0, 0) ' 表头改回黑色 + End If + + MsgBox "处理完成！请查看工作表 '订单BOM_校验版'。", vbInformation End Sub \ No newline at end of file diff --git a/VBA/vba_metadata.json b/VBA/vba_metadata.json index bb33f5b..5855e4f 100644 --- a/VBA/vba_metadata.json +++ b/VBA/vba_metadata.json @@ -31,6 +31,18 @@ "attributes": {}, "file": "DocumentModules\\Sheet4.cls" }, + "clsMaterialWithFlag.cls": { + "name": "clsMaterialWithFlag", + "type": "ClassModules", + "attributes": {}, + "file": "ClassModules\\clsMaterialWithFlag.cls" + }, + "Sheet9.cls": { + "name": "Sheet9", + "type": "DocumentModules", + "attributes": {}, + "file": "DocumentModules\\Sheet9.cls" + }, "clsCategory.cls": { "name": "clsCategory", "type": "ClassModules", @@ -55,12 +67,6 @@ "attributes": {}, "file": "ClassModules\\clsBOMManager.cls" }, - "Sheet6.cls": { - "name": "Sheet6", - "type": "DocumentModules", - "attributes": {}, - "file": "DocumentModules\\Sheet6.cls" - }, "clsModelParser.cls": { "name": "clsModelParser", "type": "ClassModules", @@ -90,6 +96,24 @@ "type": "Modules", "attributes": {}, "file": "Modules\\modModelParserExamples.bas" + }, + "Sheet16.cls": { + "name": "Sheet16", + "type": "DocumentModules", + "attributes": {}, + "file": "DocumentModules\\Sheet16.cls" + }, + "Sheet8.cls": { + "name": "Sheet8", + "type": "DocumentModules", + "attributes": {}, + "file": "DocumentModules\\Sheet8.cls" + }, + "Sheet11.cls": { + "name": "Sheet11", + "type": "DocumentModules", + "attributes": {}, + "file": "DocumentModules\\Sheet11.cls" } } } \ No newline at end of file