'===================================================================== ' 类名: BomExtractor ' 功能: BOM提取器,从平台配置清单中提取匹配的物料 '===================================================================== Option Explicit Private pWorksheet As Worksheet Private pConditionEvaluator As ConditionEvaluator Private pAllItems As Collection ' 所有BOM项 Private pMatchedItems As Collection ' 匹配的BOM项 Private pRequiredCategories As Collection ' 需要的类别 Private pCategoryHierarchy As Object ' 类别层次结构 Dictionary(子类别->父类别) Private pErrorMessages As Collection Private pExcludeCategories As Collection ' 需要排除的类别 '===================================================================== ' 方法: Class_Initialize ' 功能: 初始化类 '===================================================================== Private Sub Class_Initialize() Set pConditionEvaluator = New ConditionEvaluator Set pAllItems = New Collection Set pMatchedItems = New Collection Set pRequiredCategories = New Collection Set pCategoryHierarchy = CreateObject("Scripting.Dictionary") Set pErrorMessages = New Collection Set pExcludeCategories = New Collection End Sub '===================================================================== ' 方法: SetWorksheet ' 功能: 设置BOM数据源工作表 ' 参数: ws - 工作表对象 '===================================================================== Public Sub SetWorksheet(ws As Worksheet) Set pWorksheet = ws End Sub '===================================================================== ' 方法: LoadBomData ' 功能: 加载BOM数据 ' 返回: Boolean - 成功返回True '===================================================================== Public Function LoadBomData() As Boolean On Error GoTo ErrorHandler If pWorksheet Is Nothing Then pErrorMessages.Add "未设置工作表" LoadBomData = False Exit Function End If ' 清空现有数据 Set pAllItems = New Collection Set pCategoryHierarchy = CreateObject("Scripting.Dictionary") ' 从第4行开始读取(第3行是表头) Dim lastRow As Long lastRow = pWorksheet.Cells(pWorksheet.Rows.count, 1).End(xlUp).row Dim i As Long Dim item As BomItem For i = 4 To lastRow ' 检查行号是否为空 If Trim(pWorksheet.Cells(i, 1).value) <> "" Then Set item = New BomItem item.LoadFromRow pWorksheet, i ' 只添加有效物料(类别不为空) If item.IsValidItem Then pAllItems.Add item ' 构建类别层次结构 If item.HasParentCategory Then If Not pCategoryHierarchy.Exists(item.category) Then pCategoryHierarchy.Add item.category, item.ParentCategory End If End If Else ' 非有效物料也添加,但标记为特殊类别 pAllItems.Add item End If End If Next i LoadBomData = True Exit Function ErrorHandler: pErrorMessages.Add "加载BOM数据异常: " & Err.Description LoadBomData = False End Function '===================================================================== ' 方法: SetExcludeCategories ' 功能: 设置需要排除的类别 ' 参数: categories - 类别集合 '===================================================================== Public Sub SetExcludeCategories(categories As Collection) Set pExcludeCategories = categories End Sub '===================================================================== ' 方法: ClearExcludeCategories ' 功能: 清空排除类别列表 '===================================================================== Public Sub ClearExcludeCategories() Set pExcludeCategories = New Collection End Sub '===================================================================== ' 方法: ClearErrorMessages ' 功能: 清空错误信息列表 '===================================================================== Public Sub ClearErrorMessages() Set pErrorMessages = New Collection End Sub '===================================================================== ' 方法: ExtractBom ' 功能: 根据产品条件提取BOM ' 参数: productConditions - 产品条件字典 ' 返回: Collection - 匹配的BOM项集合 '===================================================================== Public Function ExtractBom(productConditions As Object) As Collection On Error GoTo ErrorHandler ' 清空结果 Set pMatchedItems = New Collection Set pRequiredCategories = New Collection Set pErrorMessages = New Collection ' 第一步:确定需要的类别 DetermineRequiredCategories productConditions ' 第二步:匹配物料 MatchItems productConditions ' 第三步:应用总成逻辑(父类别优先) ApplyAssemblyLogic ' 第四步:验证结果 ValidateResult Set ExtractBom = pMatchedItems Exit Function ErrorHandler: pErrorMessages.Add "提取BOM异常: " & Err.Description Set ExtractBom = pMatchedItems End Function '===================================================================== ' 方法: DetermineRequiredCategories ' 功能: 确定需要的类别 ' 参数: productConditions - 产品条件字典 '===================================================================== Private Sub DetermineRequiredCategories(productConditions As Object) Dim item As BomItem Dim uniqueCategories As Object Set uniqueCategories = CreateObject("Scripting.Dictionary") ' 遍历所有有效物料,获取唯一类别 For Each item In pAllItems If item.IsValidItem Then ' 检查是否在排除列表中 Dim isExcluded As Boolean isExcluded = False Dim excludeCat As Variant For Each excludeCat In pExcludeCategories If item.category = CStr(excludeCat) Then isExcluded = True Exit For End If Next excludeCat ' 如果不在排除列表中,继续处理 If Not isExcluded Then ' 检查类别选用条件 Dim categoryRequired As Boolean If Trim(item.CategoryCondition) = "" Then ' 无条件,必需类别 categoryRequired = True Else ' 有条件,评估条件 categoryRequired = pConditionEvaluator.Evaluate(item.CategoryCondition, productConditions) End If If categoryRequired Then If Not uniqueCategories.Exists(item.category) Then uniqueCategories.Add item.category, True pRequiredCategories.Add item.category End If End If End If End If Next item End Sub '===================================================================== ' 方法: MatchItems ' 功能: 匹配物料 ' 修改说明: 当未匹配到物料(Count=0)时不再立即报错,而是留给 ValidateResult ' 进行综合判断(因为可能存在父子覆盖或散件满足的情况)。 '===================================================================== Private Sub MatchItems(productConditions As Object) Dim item As BomItem Dim category As Variant ' 遍历每个需要的类别 For Each category In pRequiredCategories Dim categoryMatches As Collection Set categoryMatches = New Collection ' 查找该类别下所有匹配的物料 For Each item In pAllItems If item.category = category Then ' 评估选择条件 Dim matched As Boolean If Trim(item.SelectCondition) = "" Then ' 无选择条件,无条件匹配 matched = True Else ' 有选择条件,评估 matched = pConditionEvaluator.Evaluate(item.SelectCondition, productConditions) End If If matched Then item.IsMatched = True categoryMatches.Add item End If End If Next item ' 检查匹配结果 If categoryMatches.count = 0 Then ' --------------------------------------------------------- ' CHANGE: 这里不再立即报错 ' 理由: 未匹配到可能是正常的(例如:父类别缺失但子类别齐全,或者子类别被父类别覆盖) ' 具体的缺失检查移交到 ValidateResult 方法中统一处理 ' --------------------------------------------------------- ElseIf categoryMatches.count = 1 Then ' 正常:匹配到1条 pMatchedItems.Add categoryMatches(1) Else ' 异常:匹配到多条 (这个依然需要报错,因为这是数据源的不确定性错误) Dim multiMsg As String multiMsg = "类别[" & category & "]匹配到多条物料(" & categoryMatches.count & "条)" pErrorMessages.Add multiMsg ' 临时处理:输出所有匹配的 Dim tempItem As BomItem For Each tempItem In categoryMatches tempItem.MatchError = multiMsg pMatchedItems.Add tempItem Next tempItem End If Next category End Sub '===================================================================== ' 方法: ApplyAssemblyLogic ' 功能: 应用总成逻辑(父类别优先) ' 修改说明: 重构了算法,解决了以下问题: ' 1. 当某类别匹配到多条物料时,能够保留所有匹配项,而不是只输出第一条。 ' 2. 解决了因列表顺序不同导致子类别可能未被正确覆盖的潜在隐患。 '===================================================================== Private Sub ApplyAssemblyLogic() ' 1. 构建父类别->子类别映射 Dim parentToChildren As Object Set parentToChildren = CreateObject("Scripting.Dictionary") Dim parentCat As Variant Dim childCat As Variant Dim key As Variant For Each key In pCategoryHierarchy.Keys childCat = CStr(key) parentCat = pCategoryHierarchy(key) If Not parentToChildren.Exists(parentCat) Then Set parentToChildren(parentCat) = CreateObject("Scripting.Dictionary") End If parentToChildren(parentCat)(childCat) = True Next key ' 2. 统计每个类别的匹配数量 Dim categoryCounts As Object Set categoryCounts = CreateObject("Scripting.Dictionary") Dim item As BomItem For Each item In pMatchedItems If Not categoryCounts.Exists(item.category) Then categoryCounts(item.category) = 0 End If categoryCounts(item.category) = categoryCounts(item.category) + 1 Next item ' 3. 识别符合"总成优先"条件的父类别 ' 定义:如果父类别有且仅有1条匹配,且其所有子类别都有匹配,则视为满足总成逻辑 Dim coveredCategories As Object Set coveredCategories = CreateObject("Scripting.Dictionary") Dim satisfiedParentItems As Collection Set satisfiedParentItems = New Collection For Each parentCat In parentToChildren.Keys ' 只有当该父类别确实有匹配物料时才进行检查 If categoryCounts.Exists(parentCat) Then ' 条件1: 父类别只匹配到1条 (如果匹配多条,存在歧义,不应用覆盖逻辑,而是全部输出以供排查) If categoryCounts(parentCat) = 1 Then ' 条件2: 所有子类别都匹配到(至少1条) Dim childrenMatched As Boolean childrenMatched = True For Each childCat In parentToChildren(parentCat).Keys If Not categoryCounts.Exists(childCat) Then childrenMatched = False Exit For End If Next childCat If childrenMatched Then ' 满足总成条件: 找到那个父类别项 Dim pItem As BomItem For Each item In pMatchedItems If item.category = parentCat Then satisfiedParentItems.Add item Exit For End If Next item ' 标记覆盖的类别(父类别自己和所有子类别都标记为已处理) ' 这样做的目的是:在步骤4中,我们会先添加 satisfiedParentItems, ' 然后跳过 coveredCategories 中的项,从而实现"父类覆盖子类"且"父类不重复添加" coveredCategories(parentCat) = True For Each childCat In parentToChildren(parentCat).Keys coveredCategories(childCat) = True Next childCat End If End If End If Next parentCat ' 4. 构建新的结果集 Dim newMatchedItems As Collection Set newMatchedItems = New Collection ' 4.1 先添加满足条件的父类别项 (总成) For Each item In satisfiedParentItems newMatchedItems.Add item Next item ' 4.2 再添加未被覆盖的其他项 (散件 或 有问题的多条匹配项) For Each item In pMatchedItems ' 如果该项所属的类别不在"被覆盖"列表中,则保留 ' 关键点:这里不再去重!如果同一个Category有5条记录,这5条都会因为不在coveredCategories中而被添加 If Not coveredCategories.Exists(item.category) Then newMatchedItems.Add item End If Next item ' 更新结果 Set pMatchedItems = newMatchedItems End Sub '===================================================================== ' 方法: ValidateResult ' 功能: 验证提取结果 ' 修改说明: 实现了双向覆盖检查: ' 1. 子类别缺失,但父类别存在 -> 视为正常 (总成优先) ' 2. 父类别缺失,但所有必需子类别都存在 -> 视为正常 (散件满足) '===================================================================== Private Sub ValidateResult() ' 检查所有需要的类别是否都匹配 Dim category As Variant Dim categoryMatched As Object Set categoryMatched = CreateObject("Scripting.Dictionary") ' 统计已匹配的类别 Dim item As BomItem For Each item In pMatchedItems If Not categoryMatched.Exists(item.category) Then categoryMatched(item.category) = 0 End If categoryMatched(item.category) = categoryMatched(item.category) + 1 Next item ' 检查未匹配的类别 For Each category In pRequiredCategories ' 如果结果集中不存在该必需类别 If Not categoryMatched.Exists(category) Then Dim isResolved As Boolean isResolved = False ' --------------------------------------------------------- ' 检查 1: 被父类别覆盖 (总成逻辑) ' 场景: 匹配到了部件(父),自动隐藏了接头(子),接头不应报错 ' --------------------------------------------------------- If pCategoryHierarchy.Exists(category) Then Dim parentCat As String parentCat = pCategoryHierarchy(category) If categoryMatched.Exists(parentCat) Then isResolved = True End If End If ' --------------------------------------------------------- ' 检查 2: 被子类别覆盖 (散件逻辑) ' 场景: 部件(父)没匹配到(或被移除),但接头(子)和弹性元件(子)都齐了,部件不应报错 ' --------------------------------------------------------- If Not isResolved Then Dim hasRequiredChildren As Boolean Dim allChildrenMatched As Boolean hasRequiredChildren = False allChildrenMatched = True ' 遍历所有"必需"的类别,寻找当前缺失category的子类别 Dim reqCat As Variant For Each reqCat In pRequiredCategories ' 如果 reqCat 是当前 category 的子类别 If pCategoryHierarchy.Exists(reqCat) Then If pCategoryHierarchy(reqCat) = category Then hasRequiredChildren = True ' 检查这个子类别是否在结果集中 If Not categoryMatched.Exists(reqCat) Then allChildrenMatched = False Exit For ' 只要缺一个子类别,父类别就无法被视为"满足" End If End If End If Next reqCat ' 只有当存在必需子类别,且它们全都匹配时,才算通过 If hasRequiredChildren And allChildrenMatched Then isResolved = True End If End If ' --------------------------------------------------------- ' 最终判断 ' --------------------------------------------------------- If Not isResolved Then pErrorMessages.Add "必需类别[" & category & "]未匹配" End If End If Next category End Sub '===================================================================== ' 方法: GetErrorMessages ' 功能: 获取错误信息集合 ' 返回: Collection '===================================================================== Public Function GetErrorMessages() As Collection Set GetErrorMessages = pErrorMessages End Function '===================================================================== ' 方法: GetErrorSummary ' 功能: 获取错误信息摘要 ' 返回: String '===================================================================== Public Function GetErrorSummary() As String If pErrorMessages.count = 0 Then GetErrorSummary = "" Else Dim result As String Dim msg As Variant For Each msg In pErrorMessages result = result & CStr(msg) & "; " Next msg GetErrorSummary = result End If End Function