'===================================================================== ' 模块名: BIPUploadModule ' 功能: 处理产品订单数据,提取BOM后生成[BIP上传模板]格式数据 '===================================================================== Option Explicit '===================================================================== ' 常量定义 '===================================================================== ' 提取条件配置 Private Const CONDITION_CONFIG = "azxs,安装形式 |bkxs,表壳形式 |gclj,过程连接 |jycz,接液材质 |lcfw,量程范围 |fjgn,附加功能" '===================================================================== ' 过程: ProcessOrdersToBIP ' 功能: 处理产品订单数据,生成BIP上传格式 ' 说明: 主入口程序,从[产品订单]读取数据,输出到[BIP上传模板] '===================================================================== Public Sub ProcessOrdersToBIP() On Error GoTo ErrorHandler Dim startTime As Double startTime = Timer Application.ScreenUpdating = False ' 准备工作表对象 Dim orderSheet As Worksheet Dim bipSheet As Worksheet Dim bomSheet As Worksheet ' 获取[产品订单]工作表 Set orderSheet = GetOrderSheet() If orderSheet Is Nothing Then Application.ScreenUpdating = True MsgBox "未找到[产品订单]工作表!", vbCritical Exit Sub End If ' 获取[BIP上传模板]工作表 Set bipSheet = GetBIPUploadSheet() ' 获取BOM库工作表 Set bomSheet = GetBomSheet() If bomSheet Is Nothing Then Application.ScreenUpdating = True MsgBox "未找到[平台配置清单]工作表!", vbCritical Exit Sub End If ' 初始化BOM提取器 Dim BomExtractor As BomExtractor Set BomExtractor = New BomExtractor BomExtractor.SetWorksheet bomSheet If Not BomExtractor.LoadBomData Then Application.ScreenUpdating = True MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical Exit Sub End If ' 清空BIP上传模板数据(保留表头) ClearBIPSheetData bipSheet ' 写入BIP上传模板表头 WriteBIPHeader bipSheet ' 获取订单数据行数 Dim lastRow As Long lastRow = orderSheet.Cells(orderSheet.Rows.count, 1).End(xlUp).row ' 如果只有表头或没有数据 If lastRow < 2 Then Application.ScreenUpdating = True MsgBox "[产品订单]工作表中没有数据!", vbExclamation Exit Sub End If ' 【性能核心】全量读入源数据 Dim sourceDataArr As Variant sourceDataArr = orderSheet.Range("A2:G" & lastRow).value ' 【筛选核心】获取可见区域 Dim visibleRange As Range On Error Resume Next Set visibleRange = orderSheet.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible) On Error GoTo ErrorHandler If visibleRange Is Nothing Then Application.ScreenUpdating = True MsgBox "当前筛选状态下没有可见的数据。", vbInformation Exit Sub End If ' 收集所有输出数据 Dim outputData As Collection Set outputData = New Collection Dim cell As Range Dim arrIndex As Long Dim processedCount As Long Dim orderCount As Long Dim skippedCount As Long processedCount = 0 orderCount = 0 skippedCount = 0 ' 遍历筛选出来的可见单元格 For Each cell In visibleRange ' 计算内存数组索引 arrIndex = cell.row - 1 ' 读取订单数据 Dim totalQueueNum As String Dim orderNumber As String Dim ProductModel As String Dim Quantity As String Dim productCode As String Dim componentPriority As String Dim isIssueMaterial As String totalQueueNum = Trim(sourceDataArr(arrIndex, 1)) ' A列:总排号 orderNumber = Trim(sourceDataArr(arrIndex, 2)) ' B列:生产订单号 ProductModel = Trim(sourceDataArr(arrIndex, 3)) ' C列:产品型号 Quantity = Trim(sourceDataArr(arrIndex, 4)) ' D列:数量 productCode = Trim(sourceDataArr(arrIndex, 5)) ' E列:产品编码 componentPriority = Trim(sourceDataArr(arrIndex, 6)) ' F列:部件优先 isIssueMaterial = Trim(sourceDataArr(arrIndex, 7)) ' G列:是否领料 ' 【拦截逻辑】忽略[是否领料]为"否"的订单 If isIssueMaterial = "否" Then skippedCount = skippedCount + 1 GoTo ContinueLoop End If ' 跳过空行 If orderNumber = "" And ProductModel = "" Then GoTo ContinueLoop End If ' 验证必填字段 If orderNumber = "" Then MsgBox "工作表第" & cell.row & "行:生产订单号为空,跳过该行!", vbExclamation GoTo ContinueLoop End If If ProductModel = "" Then MsgBox "工作表第" & cell.row & "行:产品型号为空,跳过该行!", vbExclamation GoTo ContinueLoop End If If Quantity = "" Then MsgBox "工作表第" & cell.row & "行:数量为空,跳过该行!", vbExclamation GoTo ContinueLoop End If orderCount = orderCount + 1 ' 处理单个订单,收集输出数据 ProcessSingleOrder orderNumber, ProductModel, Quantity, productCode, _ componentPriority, BomExtractor, outputData processedCount = processedCount + 1 ContinueLoop: Next cell ' 批量写入数据到工作表 If outputData.count > 0 Then WriteBatchData bipSheet, outputData End If ' 格式化BIP上传模板 FormatBIPSheet bipSheet Dim elapsedTime As Double elapsedTime = Timer - startTime Application.ScreenUpdating = True MsgBox "处理完成!" & vbCrLf & _ "处理有效订单数: " & orderCount & vbCrLf & _ "忽略无效订单数: " & skippedCount & vbCrLf & _ "生成BIP行数: " & outputData.count & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation ' 激活BIP上传模板 bipSheet.Activate Exit Sub ErrorHandler: Application.ScreenUpdating = True MsgBox "处理异常: " & Err.Description, vbCritical End Sub '===================================================================== ' 过程: ProcessSingleOrder ' 功能: 处理单个订单,提取BOM并将数据添加到输出集合 ' 参数: orderNumber - 生产订单号 ' productModel - 产品型号 ' quantity - 生产数量 ' productCode - 产品编码 ' componentPriority - 部件优先标志("是"或"否") ' BomExtractor - BOM提取器对象 ' outputData - 输出数据集合 '===================================================================== Private Sub ProcessSingleOrder(orderNumber As String, _ ProductModel As String, _ Quantity As String, _ productCode 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 If Not parser.Parse(ProductModel) Then ' 解析失败,添加一行空物料记录 outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, 1, "") Exit Sub End If ' 提取BOM Dim matchedItems As Collection Set matchedItems = BomExtractor.ExtractBom(parser.Conditions) ' 输出结果 If matchedItems.count = 0 Then ' 没有匹配项,添加一行空物料记录 outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, 1, "") Else ' 输出每个匹配的物料 Dim item As BomItem Dim lineIndex As Long lineIndex = 1 ' 创建字典跟踪每个 BIP 行号基数的当前序号 Dim bipRowBaseDict As Object Set bipRowBaseDict = CreateObject("Scripting.Dictionary") For Each item In matchedItems ' 计算实际行号:行号 = BIP 行号基数 + 组内序号 (从 1 开始) Dim baseValue As Long baseValue = item.BipRowNumberBase Dim currentIndex As Long If bipRowBaseDict.Exists(baseValue) Then currentIndex = bipRowBaseDict(baseValue) + 1 Else currentIndex = 1 End If bipRowBaseDict(baseValue) = currentIndex Dim actualRowNumber As Long actualRowNumber = baseValue + currentIndex ' 创建 BIP 行数据并添加到集合 (已移除备注参数) outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, _ actualRowNumber, item.Code66) lineIndex = lineIndex + 1 Next item End If End Sub '===================================================================== ' 函数:CreateBIPRowArray ' 功能:创建 BIP 上传模板一行数据的数组 ' 参数:orderNumber - 生产订单号 ' productCode - 产品编码 ' quantity - 生产数量 ' actualRowNumber - 实际行号(BIP 行号基数 + 组内序号) ' materialCode - 材料编码(66 编码) ' 返回:Variant() - 包含 10 个元素的数组 '===================================================================== Private Function CreateBIPRowArray(orderNumber As String, _ productCode As String, _ Quantity As String, _ actualRowNumber As Long, _ materialCode As String) As Variant() Dim rowData(1 To 9) As Variant rowData(1) = orderNumber ' 来源单据号(生产订单号) rowData(2) = productCode ' 产品编码 rowData(3) = Quantity ' 生产数量 rowData(4) = actualRowNumber ' 行号 rowData(5) = materialCode ' 材料编码(66 编码) rowData(6) = "一般发料" ' 供应方式(固定值) rowData(7) = Date ' 需用日期(当天日期) rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织(固定值) rowData(9) = Quantity ' 计划出库数量(与生产数量一致) CreateBIPRowArray = 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 rowCount As Long rowCount = outputData.count Dim resultData() As Variant ReDim resultData(1 To rowCount, 1 To 9) ' 填充数据到二维数组 Dim i As Long Dim rowArray As Variant For i = 1 To rowCount rowArray = outputData(i) resultData(i, 1) = rowArray(1) resultData(i, 2) = rowArray(2) resultData(i, 3) = rowArray(3) resultData(i, 4) = rowArray(4) resultData(i, 5) = rowArray(5) resultData(i, 6) = rowArray(6) resultData(i, 7) = rowArray(7) resultData(i, 8) = rowArray(8) resultData(i, 9) = rowArray(9) Next i ' 一次性写入工作表(从第2行开始) ws.Range("A2").Resize(rowCount, 9).value = resultData End Sub '===================================================================== ' 过程: WriteBIPHeader ' 功能: 写入BIP上传模板表头 ' 参数: ws - 工作表对象 '===================================================================== Private Sub WriteBIPHeader(ws As Worksheet) ' 第1行:主表头 ws.Cells(1, 1).value = "来源单据号(生产订单号)" ws.Cells(1, 2).value = "产品编码" ws.Cells(1, 3).value = "生产数量" ws.Cells(1, 4).value = "行号" ws.Cells(1, 5).value = "材料编码" ws.Cells(1, 6).value = "供应方式" ws.Cells(1, 7).value = "需用日期" ws.Cells(1, 8).value = "发料组织" ws.Cells(1, 9).value = "计划出库数量" End Sub '===================================================================== ' 函数: GetOrderSheet ' 功能: 获取[产品订单]工作表 ' 返回: Worksheet - 工作表对象 '===================================================================== Private Function GetOrderSheet() As Worksheet On Error Resume Next Set GetOrderSheet = ThisWorkbook.Worksheets("产品订单") On Error GoTo 0 End Function '===================================================================== ' 函数: GetBIPUploadSheet ' 功能: 获取或创建[BIP上传模板]工作表 ' 返回: Worksheet - 工作表对象 '===================================================================== Private Function GetBIPUploadSheet() As Worksheet Dim wsName As String wsName = "BIP上传模板" On Error Resume Next Set GetBIPUploadSheet = ThisWorkbook.Worksheets(wsName) On Error GoTo 0 If GetBIPUploadSheet Is Nothing Then ' 创建新工作表 Set GetBIPUploadSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.count)) GetBIPUploadSheet.Name = wsName End If 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 '===================================================================== ' 过程: ClearBIPSheetData ' 功能: 清空BIP上传模板的数据(保留表头) ' 参数: ws - 工作表对象 '===================================================================== Private Sub ClearBIPSheetData(ws As Worksheet) ' 清空从第2行开始的所有数据 Dim lastRow As Long lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).row If lastRow > 1 Then ws.Rows("2:" & lastRow).ClearContents End If End Sub '===================================================================== ' 过程: FormatBIPSheet ' 功能: 格式化BIP上传模板工作表 ' 参数: ws - 工作表对象 '===================================================================== Private Sub FormatBIPSheet(ws As Worksheet) On Error Resume Next ' 设置表头格式 With ws.Rows(1) .Font.Bold = True .Interior.Color = RGB(217, 217, 217) .HorizontalAlignment = xlCenter End With ' 设置所有单元格居中对齐 With ws.UsedRange .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter End With ' 自动调整列宽 ws.Columns.AutoFit ' 设置日期列格式 ws.Columns(7).NumberFormat = "yyyy/mm/dd" On Error GoTo 0 End Sub