Files
AutoBOM/VBA_BOMConverter/Modules/M09_BOMExtractor.bas
Misaka_Company e086dee920
All checks were successful
NTFY Notification / notify (push) Successful in 4s
feat: implement BIP upload worksheet with quantity calculation fix
This commit implements the BIP upload worksheet functionality for ERP system integration and fixes a critical bug in quantity calculation.

Changes:
1. Added BIP upload configuration constants to M04_Config.bas
   - BIP_UPLOAD_SHEET_NAME = "BIP上传"
   - BIP_ROW_NUMBER_BASE = 7000
   - BIP_SUPPLY_MODE = "一般发料"
   - BIP_ISSUE_ORG = "重庆布莱迪仪器仪表有限公司"

2. Extended input data reading to 4 columns (M09_BOMExtractor.bas)
   - Column D: Product Code (产品编码)
   - Updated ReadInputModels to read columns A:D

3. Added product code mapping in main flow
   - Created productCodeMap Dictionary to store order number -> product code mappings
   - Stored product codes during input processing loop

4. Created WriteBIPUploadResults function
   - Generates 9-column BIP upload worksheet
   - Implements row number generation (7000 + material sequence number)
   - Resets sequence counter for each new order
   - Includes all rows (including error rows)
   - Formats worksheet with borders, column widths, and freeze panes

5. **CRITICAL FIX**: Corrected quantity calculation logic
   - Added order quantity lookup from inputModels
   - Changed from: materialQty = result(12) (BOM base quantity only)
   - Changed to: finalQty = bomQty * currentOrderQty
   - Applied fix to both "生产数量" (column 3) and "计划出库数量" (column 9)
   - Updated comment to clarify result(12) is BOM base quantity

Output Format (9 columns):
1. 来源单据号 (Source Document Number) - Production Order No
2. 产品编码 (Product Code)
3. 生产数量 (Production Quantity) = Order Qty × Material Qty
4. 行号 (Row Number) = 7000 + sequence (resets per order)
5. 材料编码 (Material Code)
6. 供应方式 (Supply Mode) = "一般发料"
7. 需用日期 (Required Date) = Current date (yyyy/m/d format)
8. 发料组织 (Issue Organization) = "重庆布莱迪仪器仪表有限公司"
9. 计划出库数量 (Planned Output Qty) = Order Qty × Material Qty

Business Rules Implemented:
- Error rows are included (material code is empty, quantities are 0)
- Empty product codes are written as empty strings
- Row numbers reset to 7001 for each new order
- Material quantities are correctly calculated as order quantity × BOM quantity

Co-Authored-By: Claude Sonnet 4.5 <noreply@anthropic.com>
2026-02-26 14:41:58 +08:00

1423 lines
47 KiB
QBasic
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
' ==============================================================================
' 模块: 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 Const MAPPING_SHEET_NAME As String = "对照表"
' 模块级变量
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
' 初始化部件处理器(带库存校验)- 现存量在主工作簿中
Dim invWorkbook As Workbook
Set invWorkbook = ThisWorkbook ' 现存量在主工作簿中
M08_ComponentProcessor.InitComponentProcessorWithInventory g_Logger, invWorkbook
' 初始化映射器(新增)
If WorksheetExists(MAPPING_SHEET_NAME) Then
Dim wsMapping As Worksheet
Set wsMapping = ThisWorkbook.Sheets(MAPPING_SHEET_NAME)
M06A_Mapper.InitMapper g_Logger, wsMapping
Else
If Not g_Logger Is Nothing Then
g_Logger.RecordWarning "", "M09.RunBOMExtraction", "MappingTableMissing", _
"未找到对照表工作表azxs和lcfw将仅使用原始值匹配", ""
End If
End If
' 步骤4: 处理每个产品型号
Application.StatusBar = "正在处理产品型号..."
Dim allResults As Collection
Set allResults = New Collection
' 产品编码映射用于BIP上传工作表生成
Dim productCodeMap As Object
Set productCodeMap = CreateObject("Scripting.Dictionary")
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 productionOrderNo As String
Dim modelString As String
Dim orderQty As Long
Dim productCode As String
productionOrderNo = CStr(inputModels(i, 1)) ' Column A: 生产订单号
modelString = CStr(inputModels(i, 2)) ' Column B: 产品型号
orderQty = CLng(inputModels(i, 3)) ' Column C: 数量
productCode = CStr(inputModels(i, 4)) ' Column D: 产品编码
' 存储产品编码映射用于BIP上传
If Not productCodeMap.Exists(productionOrderNo) Then
productCodeMap.Add productionOrderNo, productCode
End If
Dim modelResults As Collection
Set modelResults = ProcessSingleModel(modelString, g_BOMWorkbook, g_Logger, productionOrderNo, orderQty)
' 合并结果
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)
' 步骤5.5: 生成BIP上传工作表
Application.StatusBar = "正在生成BIP上传数据..."
Dim wsBIPUpload As Worksheet
Set wsBIPUpload = WriteBIPUploadResults(allResults, inputModels, productCodeMap)
If wsBIPUpload Is Nothing Then
RunBOMExtraction = "错误无法生成BIP上传工作表。"
GoTo ExitHandler
End If
' 步骤6: 生成错误报告
If g_Logger.HasIssues 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(13))) = 0 Then ' 第13列是备注
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 & "发现错误,已生成错误报告工作表。"
ElseIf g_Logger.HasWarnings 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
' 读取数据到数组返回4列生产订单号、产品型号、数量、产品编码
' 假设A列(1)=生产订单号, B列(2)=产品型号, C列(3)=数量, D列(4)=产品编码
ReadInputModels = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, 4)).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, _
ByVal productionOrderNo As String, _
ByVal orderQty As Long _
) 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, "型号解析失败:型号格式不正确或缺少必要字段", productionOrderNo, True)
Set ProcessSingleModel = results
Exit Function
End If
' 步骤2: 匹配所有物料类型(两阶段)
Dim allMaterials As Collection
Dim validation As Object
Set allMaterials = MatchAllMaterialTypesWithValidation(params, bomWb, logger, orderQty, productionOrderNo, validation)
' 步骤3: 生成输出行
Dim remarks As String
remarks = ""
If Not validation("valid") Then
remarks = validation("message")
End If
' 生成物料行(第一条显示生产订单号,其余不显示)
Dim isFirstRow As Boolean
isFirstRow = True
Dim mat As Variant
For Each mat In allMaterials
Dim outputRow As Variant
outputRow = GenerateMaterialRow(modelString, params, mat, remarks, productionOrderNo, isFirstRow)
results.Add outputRow
isFirstRow = False
Next mat
' 如果没有匹配到任何物料,添加错误行
If allMaterials.count = 0 Then
results.Add GenerateErrorRow(modelString, "未匹配到任何物料", productionOrderNo, True)
End If
Set ProcessSingleModel = results
Exit Function
ErrorHandler:
If Not logger Is Nothing Then
logger.Record productionOrderNo, "M09.ProcessSingleModel", "SystemError", _
"处理型号[" & modelString & "]失败: " & Err.Description, ""
End If
results.Add GenerateErrorRow(modelString, "系统错误: " & Err.Description, productionOrderNo, True)
Set ProcessSingleModel = results
End Function
' ------------------------------------------------------------------------------
' 匹配所有物料类型(两阶段:收集 → 验证)
'
' 输入:
' params - 参数字典
' bomWb - BOM库工作簿
' logger - 错误记录器
' validation - 输出参数,返回验证结果
'
' 输出:
' Collection - 所有匹配到的物料集合
'
' 逻辑:
' Phase 1: 收集阶段 - 遍历BOM库中的所有工作表收集匹配结果不记录错误
' Phase 2: 验证阶段 - 统一验证所有结果,记录错误和警告
' Phase 3: 生成最终物料集合
'
' 特殊处理:
' - "部件"工作表特殊处理调用M08_ComponentProcessor
' - 部件、接头、弹性元件的交叉验证
' - 边材料基于azxs参数的特殊验证A0/Z0/B0不需要边AH/AT等需要边
' ------------------------------------------------------------------------------
Private Function MatchAllMaterialTypesWithValidation( _
ByVal params As Object, _
ByVal bomWb As Workbook, _
ByVal logger As clsErrorLogger, _
ByVal orderQty As Long, _
ByVal productionOrderNo As String, _
ByRef outValidation As Object _
) As Collection
On Error GoTo ErrorHandler
' ========================================
' Phase 1: 收集所有工作表的匹配结果
' ========================================
Dim resultsDict As Object
Set resultsDict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet
For Each ws In bomWb.Worksheets
Dim sheetName As String
sheetName = ws.Name
Debug.Print "=== 处理工作表: [" & sheetName & "] ==="
' 创建匹配结果对象
Dim matchResult As Object
Set matchResult = CreateObject("Scripting.Dictionary")
matchResult("sheetName") = sheetName
matchResult("success") = False
matchResult("rowCount") = 0
Set matchResult("rowNums") = New Collection
Set matchResult("materials") = New Collection
' "部件"工作表特殊处理
Dim componentMaterials As Collection
If sheetName = BOMLIB_SHEET_COMPONENT Then
Debug.Print " -> 使用部件处理逻辑"
' 步骤1: 先调用标准匹配获取匹配行数(这是工作表匹配的行数,不是物料数量)
Dim bomMatchResult As Object
Set bomMatchResult = M07_BOMMatcher.MatchBOMRecord(ws, params)
Debug.Print " -> 标准匹配: success=" & bomMatchResult("success") & ", rowCount=" & bomMatchResult("rowCount")
' 步骤2: 如果标准匹配成功,调用部件处理器
Set componentMaterials = New Collection
If bomMatchResult("success") Then
Set componentMaterials = M08_ComponentProcessor.ProcessComponentRecord( _
ws, params, logger, bomMatchResult("rowNums")(1), orderQty, productionOrderNo)
Debug.Print " -> 返回物料数: " & componentMaterials.count
End If
' 步骤3: 创建匹配结果对象使用标准匹配的rowCount工作表行数不是物料数
matchResult("success") = bomMatchResult("success")
matchResult("rowCount") = bomMatchResult("rowCount") ' ✅ 关键修复使用标准匹配的rowCount
Set matchResult("rowNums") = bomMatchResult("rowNums")
' 步骤4: 添加物料到匹配结果
Dim compMat As Variant
For Each compMat In componentMaterials
Debug.Print " [" & compMat("materialType") & "] 名称=[" & compMat("materialName") & "] 编码=[" & compMat("materialCode") & "]"
matchResult("materials").Add compMat
Next compMat
Else
' 其他工作表使用标准匹配逻辑
Set bomMatchResult = M07_BOMMatcher.MatchBOMRecord(ws, params)
Debug.Print " -> 匹配结果: " & bomMatchResult("success") & ", 行数: " & bomMatchResult("rowCount")
matchResult("success") = bomMatchResult("success")
matchResult("rowCount") = bomMatchResult("rowCount")
Set matchResult("rowNums") = bomMatchResult("rowNums")
' 提取物料信息(支持多条匹配)
If bomMatchResult("rowCount") > 0 Then
' 步骤1: 构建表头映射(只需构建一次)
Dim headerMap As Object
Set headerMap = M07_BOMMatcher.BuildWorksheetHeaderMap(ws)
' 步骤2: 遍历所有匹配行
Dim i As Long
Dim rowNum As Long
For i = 1 To bomMatchResult("rowCount")
rowNum = bomMatchResult("rowNums")(i)
Debug.Print " -> 处理匹配行 " & i & "/" & bomMatchResult("rowCount") & ": 行号=" & rowNum
' 步骤3: 提取物料信息
Dim materialInfo As Object
Set materialInfo = M07_BOMMatcher.ExtractMaterialInfo(ws, rowNum, headerMap)
If Not materialInfo Is Nothing Then
matchResult("materials").Add materialInfo
Debug.Print " 已添加: 名称=[" & materialInfo("materialName") & "] 编码=[" & materialInfo("materialCode") & "]"
Else
Debug.Print " ERROR: materialInfo为Nothing"
End If
Next i
Debug.Print " -> 共添加 " & matchResult("materials").Count & " 个物料"
End If
End If
' 将匹配结果存入字典
resultsDict.Add sheetName, matchResult
Debug.Print ""
Next ws
' ========================================
' Phase 2: 统一验证所有匹配结果
' ========================================
Dim validationResult As Object
Set validationResult = ValidateAllMatchResults(resultsDict, logger, params, productionOrderNo)
' ========================================
' Phase 3: 根据验证结果生成最终物料集合
' ========================================
Dim allMaterials As Collection
Set allMaterials = New Collection
If validationResult("valid") Then
' 验证通过,收集所有物料
Dim resultKey As Variant
For Each resultKey In resultsDict.Keys
Dim result As Object
Set result = resultsDict(resultKey)
Dim mat As Variant
For Each mat In result("materials")
allMaterials.Add mat
Next mat
Next resultKey
Else
' 验证失败,仍然收集物料以便在输出中显示错误
Dim resultKey2 As Variant
For Each resultKey2 In resultsDict.Keys
Dim result2 As Object
Set result2 = resultsDict(resultKey2)
Dim mat2 As Variant
For Each mat2 In result2("materials")
allMaterials.Add mat2
Next mat2
Next resultKey2
End If
' 设置输出参数
Set outValidation = validationResult
Set MatchAllMaterialTypesWithValidation = allMaterials
Exit Function
ErrorHandler:
If Not logger Is Nothing Then
logger.Record productionOrderNo, "M09.MatchAllMaterialTypesWithValidation", "SystemError", _
"匹配物料类型失败: " & Err.Description, ""
End If
Dim emptyColl As Collection
Set emptyColl = New Collection
Set MatchAllMaterialTypesWithValidation = emptyColl
End Function
' ------------------------------------------------------------------------------
' 统一验证所有工作表的匹配结果
'
' 输入:
' resultsDict - 所有工作表的匹配结果字典
' logger - 错误记录器
' params - 产品型号参数字典(用于边材料验证)
'
' 输出:
' Object - 验证结果对象
' .valid - Boolean验证是否通过
' .message - String错误/警告消息
'
' 验证规则:
' 1. 基础规则(所有工作表):
' - 恰好匹配1条记录 → 正常
' - 匹配0条记录 → 错误(部件/接头/弹性元件/边除外)
' - 匹配2+条记录 → 错误
'
' 2. 特殊规则(部件、接头、弹性元件):
' - 互斥关系验证
' - 组合完整性验证
' - 警告处理
'
' 3. 特殊规则(边材料):
' - azxs=A0/Z0/B0 → 不需要边0条=OK1+条=ERROR
' - azxs=AH/AT/BH/BT/BZ/ZH/ZT/ZZ → 需要边1条=OK
' - 支持双值格式(如"A0,径向"
' ------------------------------------------------------------------------------
Private Function ValidateAllMatchResults( _
ByVal resultsDict As Object, _
ByVal logger As clsErrorLogger, _
ByVal params As Object, _
ByVal productionOrderNo As String _
) As Object
On Error GoTo ErrorHandler
Dim validation As Object
Set validation = CreateObject("Scripting.Dictionary")
validation("valid") = True
validation("message") = ""
' ========================================
' 1. 基础验证非特殊工作表必须恰好1条
' ========================================
Dim specialSheets As Variant
specialSheets = Array(BOMLIB_SHEET_COMPONENT, "接头", "弹性元件", BOMLIB_SHEET_EDGE)
Dim errors As Collection
Set errors = New Collection
Dim warnings As Collection
Set warnings = New Collection
Dim sheetKey As Variant
For Each sheetKey In resultsDict.Keys
Dim result As Object
Set result = resultsDict(sheetKey)
Dim isSpecialSheet As Boolean
isSpecialSheet = False
Dim s As Variant
For Each s In specialSheets
If result("sheetName") = s Then
isSpecialSheet = True
Exit For
End If
Next s
If Not isSpecialSheet Then
If result("rowCount") = 0 Then
errors.Add result("sheetName") & " 未匹配到记录"
ElseIf result("rowCount") > 1 Then
errors.Add result("sheetName") & " 匹配到" & result("rowCount") & "条记录"
End If
End If
Next sheetKey
' ========================================
' 2. 统计特殊工作表的结果
' ========================================
Dim componentResult As Object
Set componentResult = Nothing
Dim jointResult As Object
Set jointResult = Nothing
Dim elementResult As Object
Set elementResult = Nothing
If resultsDict.Exists(BOMLIB_SHEET_COMPONENT) Then
Set componentResult = resultsDict(BOMLIB_SHEET_COMPONENT)
End If
If resultsDict.Exists("接头") Then
Set jointResult = resultsDict("接头")
End If
If resultsDict.Exists("弹性元件") Then
Set elementResult = resultsDict("弹性元件")
End If
' 统计[部件]工作表中返回的物料类型
Dim componentFromComponentSheet As Boolean
componentFromComponentSheet = False
Dim componentJointCount As Long
componentJointCount = 0
Dim componentElementCount As Long
componentElementCount = 0
If Not componentResult Is Nothing Then
Dim mat As Variant
For Each mat In componentResult("materials")
If mat("materialType") = BOMLIB_SHEET_COMPONENT Then
componentFromComponentSheet = True
ElseIf mat("materialType") = "接头" Then
componentJointCount = componentJointCount + 1
ElseIf mat("materialType") = "弹性元件" Then
componentElementCount = componentElementCount + 1
End If
Next mat
End If
' ========================================
' 3. 特殊验证:部件、接头、弹性元件
' ========================================
Dim jointFromSheet As Long
jointFromSheet = 0
Dim elementFromSheet As Long
elementFromSheet = 0
If Not jointResult Is Nothing Then
jointFromSheet = jointResult("rowCount")
End If
If Not elementResult Is Nothing Then
elementFromSheet = elementResult("rowCount")
End If
' 情况A: [部件]工作表返回了部件物料
If componentFromComponentSheet Then
' 检查独立工作表是否也匹配到了物料
If jointFromSheet > 0 Then
warnings.Add "存在[部件]物料,但[接头]工作表也匹配到" & jointFromSheet & "条记录,已忽略"
End If
If elementFromSheet > 0 Then
warnings.Add "存在[部件]物料,但[弹性元件]工作表也匹配到" & elementFromSheet & "条记录,已忽略"
End If
' 情况B: [部件]工作表返回了子件(接头+弹性元件)
ElseIf componentJointCount > 0 Or componentElementCount > 0 Then
If jointFromSheet > 0 Then
warnings.Add "[部件]工作表已返回接头,但[接头]工作表也匹配到" & jointFromSheet & "条记录,已忽略"
End If
If elementFromSheet > 0 Then
warnings.Add "[部件]工作表已返回弹性元件,但[弹性元件]工作表也匹配到" & elementFromSheet & "条记录,已忽略"
End If
' 情况C: [部件]工作表没有返回物料,使用独立工作表
Else
' 检查[部件]工作表本身是否匹配失败
Dim componentCount As Long
componentCount = 0
If Not componentResult Is Nothing Then
componentCount = componentResult("rowCount")
End If
If componentCount = 0 And (jointFromSheet = 0 Or elementFromSheet = 0) Then
errors.Add "部件、接头、弹性元件均未匹配或组合不完整"
ElseIf jointFromSheet > 1 Then
errors.Add "[接头]工作表匹配到" & jointFromSheet & "条记录"
ElseIf elementFromSheet > 1 Then
errors.Add "[弹性元件]工作表匹配到" & elementFromSheet & "条记录"
End If
End If
' ========================================
' 3.5. 特殊验证:边 (Edge) 材料
' ========================================
Dim edgeResult As Object
Set edgeResult = Nothing
If resultsDict.Exists(BOMLIB_SHEET_EDGE) Then
Set edgeResult = resultsDict(BOMLIB_SHEET_EDGE)
End If
' 检查azxs参数值
Dim azxsValue As String
Dim rawAzxs As String
azxsValue = ""
rawAzxs = ""
If params.Exists("azxs") Then
azxsValue = CStr(params("azxs"))
' 提取原始azxs值处理双值格式如"A0,径向"
If InStr(azxsValue, ",") > 0 Then
rawAzxs = Trim(CStr(Split(azxsValue, ",")(0)))
Else
rawAzxs = Trim(azxsValue)
End If
End If
' 定义不需要边的azxs值
Dim noEdgeAzxs As Variant
noEdgeAzxs = Array("A0", "Z0", "B0")
' 定义需要边的azxs值有后缀H/T/Z的值
Dim hasEdgeAzxs As Variant
hasEdgeAzxs = Array("AH", "AT", "BH", "BT", "BZ", "ZH", "ZT", "ZZ")
' 检查是否为不需要边的azxs值
Dim isNoEdgeCase As Boolean
isNoEdgeCase = False
Dim az As Variant
For Each az In noEdgeAzxs
If rawAzxs = az Then
isNoEdgeCase = True
Exit For
End If
Next az
' 情况A: azxs为A0/Z0/B0不应该有边
If isNoEdgeCase Then
If Not edgeResult Is Nothing Then
If edgeResult("rowCount") > 0 Then
errors.Add "[边]工作表匹配到" & edgeResult("rowCount") & "条记录但azxs=" & rawAzxs & "不需要边物料"
End If
End If
' 0条匹配是正常的不记录错误或警告
' 情况B: azxs为AH/AT/BH/BT/BZ/ZH/ZT/ZZ走常规判断
Else
' 检查是否为需要边的azxs值
Dim isHasEdgeCase As Boolean
isHasEdgeCase = False
For Each az In hasEdgeAzxs
If rawAzxs = az Then
isHasEdgeCase = True
Exit For
End If
Next az
If isHasEdgeCase Then
' 标准验证恰好1条匹配
If Not edgeResult Is Nothing Then
If edgeResult("rowCount") = 0 Then
errors.Add "[边]未匹配到记录"
ElseIf edgeResult("rowCount") > 1 Then
errors.Add "[边]匹配到" & edgeResult("rowCount") & "条记录"
End If
Else
' 没有边的结果记录
errors.Add "[边]未匹配到记录"
End If
End If
End If
' ========================================
' 4. 处理[部件]工作表的多条匹配
' ========================================
If Not componentResult Is Nothing Then
If componentResult("rowCount") > 1 Then
errors.Add "[部件]工作表匹配到" & componentResult("rowCount") & "条记录"
End If
End If
' ========================================
' 5. 记录错误和警告
' ========================================
Dim err As Variant
For Each err In errors
logger.Record productionOrderNo, "M09.ValidateAllMatchResults", "BOMMatchError", CStr(err), ""
Next err
Dim warn As Variant
For Each warn In warnings
logger.RecordWarning productionOrderNo, "M09.ValidateAllMatchResults", "ComponentConflict", CStr(warn), ""
Next warn
' ========================================
' 6. 生成验证结果
' ========================================
If errors.count > 0 Then
validation("valid") = False
validation("message") = Join(ToArray(errors), "; ")
ElseIf warnings.count > 0 Then
validation("valid") = True ' 警告不影响验证结果
validation("message") = Join(ToArray(warnings), "; ")
End If
Set ValidateAllMatchResults = validation
Exit Function
ErrorHandler:
If Not logger Is Nothing Then
logger.Record productionOrderNo, "M09.ValidateAllMatchResults", "SystemError", _
"验证匹配结果失败: " & Err.Description, ""
End If
validation("valid") = False
validation("message") = "验证过程发生系统错误"
Set ValidateAllMatchResults = validation
End Function
' ------------------------------------------------------------------------------
' 辅助函数将Collection转换为数组
' ------------------------------------------------------------------------------
Private Function ToArray(ByVal coll As Collection) As Variant
Dim arr() As Variant
ReDim arr(1 To coll.count) As Variant
Dim i As Long
For i = 1 To coll.count
arr(i) = coll(i)
Next i
ToArray = arr
End Function
' ------------------------------------------------------------------------------
' 生成单行输出数据
'
' 输入:
' modelString - 原始产品型号
' params - 参数字典
' material - 物料信息字典
' remarks - 备注信息
' productionOrderNo - 生产订单号
' isFirstRow - 是否为第一条记录(用于控制生产订单号显示)
'
' 输出:
' Variant - 包含13列数据的数组
'
' 列定义:
' 1: 生产订单号(仅第一条记录显示)
' 2: 原始产品型号
' 3: azxs
' 4: bkxs
' 5: gclj
' 6: jycz
' 7: lcfw
' 8: fjgn
' 9: 物料类型
' 10: 物料名称
' 11: 物料编码
' 12: 物料数量
' 13: 提取备注
' ------------------------------------------------------------------------------
Private Function GenerateMaterialRow( _
ByVal modelString As String, _
ByVal params As Object, _
ByVal material As Object, _
ByVal remarks As String, _
ByVal productionOrderNo As String, _
ByVal isFirstRow As Boolean _
) As Variant
Dim result(1 To 13) As Variant
' 第1列: 生产订单号(仅第一条记录显示)
If isFirstRow Then
result(1) = productionOrderNo
Else
result(1) = ""
End If
' 第2列: 原始产品型号
result(2) = modelString
' 第3-8列: 参数值
result(3) = GetParamValue(params, "azxs")
result(4) = GetParamValue(params, "bkxs")
result(5) = GetParamValue(params, "gclj")
result(6) = GetParamValue(params, "jycz")
result(7) = GetParamValue(params, "lcfw")
result(8) = GetParamValue(params, "fjgn")
' 第9-12列: 物料信息
result(9) = GetMaterialValue(material, "materialType")
result(10) = GetMaterialValue(material, "materialName")
result(11) = GetMaterialValue(material, "materialCode")
result(12) = GetMaterialValue(material, "materialQty")
' 第13列: 备注
result(13) = remarks & " " & GetMaterialValue(material, "remarks")
result(13) = Trim(result(13))
GenerateMaterialRow = result
End Function
' ------------------------------------------------------------------------------
' 生成错误行
'
' 输入:
' modelString - 原始产品型号
' errorMessage - 错误消息
' productionOrderNo - 生产订单号
' isFirstRow - 是否为第一条记录(错误行总是显示生产订单号)
'
' 输出:
' Variant - 包含13列数据的数组仅生产订单号、型号和备注有值
' ------------------------------------------------------------------------------
Private Function GenerateErrorRow( _
ByVal modelString As String, _
ByVal errorMessage As String, _
ByVal productionOrderNo As String, _
ByVal isFirstRow As Boolean _
) As Variant
Dim result(1 To 13) As Variant
Dim i As Long
For i = 1 To 13
result(i) = ""
Next i
result(1) = productionOrderNo
result(2) = modelString
result(13) = "错误: " & 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 13
ws.Cells(1, c).Value = headers(c - 1)
Next c
' 格式化表头
With ws.Range("A1:M1")
.Font.Bold = True
.Interior.Color = RGB(217, 217, 217)
.HorizontalAlignment = xlCenter
End With
' 写入数据
If results.count > 0 Then
' 先设置物料编码列第11列K列为文本格式
ws.Range("K2:K" & (results.count + 1)).NumberFormat = "@"
' 准备输出数组
Dim outputArr() As Variant
ReDim outputArr(1 To results.count, 1 To 13)
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 13
outputArr(i, j) = result(j)
Next j
Next i
ws.Range("A2").Resize(results.count, 13).Value = outputArr
' 格式化数据区域
With ws.Range("A2:M" & (results.count + 1))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
' 如果有错误备注,标红;如果有警告,标黄
For i = 1 To results.count
Dim remarkText As String
remarkText = CStr(outputArr(i, 13))
If Len(remarkText) > 0 Then
If InStr(remarkText, "错误") > 0 Then
ws.Cells(i + 1, 13).Interior.Color = RGB(255, 200, 200)
ElseIf InStr(remarkText, "警告") > 0 Or InStr(remarkText, "已忽略") > 0 Then
ws.Cells(i + 1, 13).Interior.Color = RGB(255, 255, 200)
End If
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
' ------------------------------------------------------------------------------
' 写入BIP上传数据到工作表
'
' 输入:
' results - 提取结果集合来自BOM提取结果
' inputModels - 输入数据数组(包含订单号、型号、数量、产品编码)
' productCodeMap - 产品编码映射字典(订单号 -> 产品编码)
'
' 输出:
' Worksheet - BIP上传工作表
'
' 逻辑:
' 1. 创建或清空"BIP上传"工作表
' 2. 写入表头9列
' 3. 构建输出数据:
' - 检测订单号变化(重置物料行号计数器)
' - 生成行号7000 + 物料流水号1, 2, 3...
' - 查找产品编码和订单数量
' - 提取物料编码和数量
' - 填充固定值字段
' 4. 批量写入数据
' 5. 格式化工作表(边框、列宽、数字格式)
'
' 输出格式9列:
' 1: 来源单据号(生产订单号)
' 2: 产品编码
' 3: 生产数量(订单数量×物料数量)
' 4: 行号7000 + 流水号)
' 5: 材料编码
' 6: 供应方式(固定值:"一般发料"
' 7: 需用日期当前日期格式yyyy/m/d
' 8: 发料组织(固定值:"重庆布莱迪仪器仪表有限公司"
' 9: 计划出库数量(与生产数量相同)
' ------------------------------------------------------------------------------
Private Function WriteBIPUploadResults( _
ByVal results As Collection, _
ByVal inputModels As Variant, _
ByVal productCodeMap As Object _
) As Worksheet
On Error GoTo ErrorHandler
Dim ws As Worksheet
' 创建或获取工作表
On Error Resume Next
Set ws = ThisWorkbook.Sheets(BIP_UPLOAD_SHEET_NAME)
On Error GoTo ErrorHandler
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count))
ws.Name = BIP_UPLOAD_SHEET_NAME
Else
ws.Cells.Clear
End If
' 写入表头9列
Dim headers As Variant
headers = Array("来源单据号(生产订单号)", "产品编码", "生产数量", "行号", "材料编码", _
"供应方式", "需用日期", "发料组织", "计划出库数量")
Dim c As Long
For c = 1 To 9
ws.Cells(1, c).Value = headers(c - 1)
Next c
' 格式化表头
With ws.Range("A1:I1")
.Font.Bold = True
.Interior.Color = RGB(217, 217, 217)
.HorizontalAlignment = xlCenter
End With
' 写入数据
If results.count > 0 Then
' 先设置材料编码列第5列E列为文本格式
ws.Range("E2:E" & (results.count + 1)).NumberFormat = "@"
' 准备输出数组
Dim outputArr() As Variant
ReDim outputArr(1 To results.count, 1 To 9)
' 行号生成变量
Dim currentOrderNo As String
Dim materialSeqNum As Long
materialSeqNum = 0
currentOrderNo = ""
Dim i As Long
Dim result As Variant
For i = 1 To results.count
result = results(i)
' 提取订单号注意result(1)在非第一行时为空需要从第2列获取原始型号来判断
Dim resultOrderNo As String
Dim resultModel As String
resultOrderNo = CStr(result(1)) ' 第1列生产订单号仅第一条记录有值
resultModel = CStr(result(2)) ' 第2列原始产品型号
' 检测新订单,重置计数器
' 如果resultOrderNo不为空说明是新订单的第一条记录
If Len(Trim(resultOrderNo)) > 0 And resultOrderNo <> currentOrderNo Then
currentOrderNo = resultOrderNo
materialSeqNum = 0
End If
' 行号计数器递增
materialSeqNum = materialSeqNum + 1
' 生成行号7000 + 流水号
Dim bipRowNum As Long
bipRowNum = BIP_ROW_NUMBER_BASE + materialSeqNum
' 查找产品编码使用currentOrderNo
Dim currentProductCode As String
If productCodeMap.Exists(currentOrderNo) Then
currentProductCode = CStr(productCodeMap(currentOrderNo))
Else
currentProductCode = ""
End If
' 【新增】查找订单数量使用currentOrderNo
Dim currentOrderQty As Long
currentOrderQty = 1 ' 默认值
' 遍历inputModels查找订单数量
Dim j As Long
For j = LBound(inputModels, 1) To UBound(inputModels, 1)
If CStr(inputModels(j, 1)) = currentOrderNo Then
currentOrderQty = CLng(inputModels(j, 3)) ' 第3列是订单数量
Exit For
End If
Next j
' 提取物料编码和BOM库基础数量
Dim materialCode As String
Dim bomQty As Long
Dim finalQty As Long
Dim isErrorRow As Boolean
materialCode = CStr(result(11)) ' 第11列物料编码
' 检查是否为错误行(物料编码为空)
isErrorRow = (Len(Trim(materialCode)) = 0)
' 第12列BOM库基础数量需要乘以订单数量
If Not isErrorRow Then
bomQty = CLng(result(12))
Else
bomQty = 0
End If
' 【新增】计算最终数量 = 订单数量 × BOM数量
finalQty = bomQty * currentOrderQty
' 填充输出数组使用currentOrderNo确保每一行都有订单号
outputArr(i, 1) = currentOrderNo ' 来源单据号(生产订单号)
outputArr(i, 2) = currentProductCode ' 产品编码
outputArr(i, 3) = finalQty ' 生产数量 = 订单数量 × BOM数量
outputArr(i, 4) = bipRowNum ' 行号
outputArr(i, 5) = materialCode ' 材料编码
outputArr(i, 6) = BIP_SUPPLY_MODE ' 供应方式
outputArr(i, 7) = Format(Date, "yyyy/m/d") ' 需用日期
outputArr(i, 8) = BIP_ISSUE_ORG ' 发料组织
outputArr(i, 9) = finalQty ' 计划出库数量 = 订单数量 × BOM数量
Next i
' 批量写入数据
ws.Range("A2").Resize(results.count, 9).Value = outputArr
' 格式化数据区域
With ws.Range("A2:I" & (results.count + 1))
.Borders.LineStyle = xlContinuous
.Borders.Weight = xlThin
End With
' 设置列宽
ws.Columns("A").ColumnWidth = 15 ' 来源单据号
ws.Columns("B").ColumnWidth = 15 ' 产品编码
ws.Columns("C").ColumnWidth = 10 ' 生产数量
ws.Columns("D").ColumnWidth = 8 ' 行号
ws.Columns("E").ColumnWidth = 15 ' 材料编码
ws.Columns("F").ColumnWidth = 12 ' 供应方式
ws.Columns("G").ColumnWidth = 12 ' 需用日期
ws.Columns("H").ColumnWidth = 25 ' 发料组织
ws.Columns("I").ColumnWidth = 12 ' 计划出库数量
' 冻结首行
ws.Activate
ActiveWindow.FreezePanes = False
ws.Rows(2).Select
ActiveWindow.FreezePanes = True
ws.Cells(1, 1).Select
End If
Set WriteBIPUploadResults = ws
Exit Function
ErrorHandler:
Set WriteBIPUploadResults = 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
' ------------------------------------------------------------------------------
' 检查工作表是否存在
'
' 输入:
' sheetName - 工作表名称
'
' 输出:
' Boolean - True表示工作表存在False表示不存在
' ------------------------------------------------------------------------------
Private Function WorksheetExists(ByVal sheetName As String) As Boolean
On Error Resume Next
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(sheetName)
WorksheetExists = Not ws Is Nothing
On Error GoTo 0
End Function