From d68dc945bcaf13a5125fa11ec07b5a01422a9b52 Mon Sep 17 00:00:00 2001 From: Misaka Date: Sun, 1 Feb 2026 23:06:26 +0800 Subject: [PATCH] perf: optimize output logic using batch array writes Optimize BIPUploadModule and MainModule for better performance: - Replace cell-by-cell writes with batch array operations - Collect all output data in memory using Collection objects - Use WriteBatchData to write all data in single operation - Add CreateBIPRowArray and CreateOutputRowArray helper functions - Remove deprecated WriteBIPRow and WriteOutputRow functions Performance improvement: - Before: N cell write operations per row (thousands of Excel calls) - After: 1 batch write operation for all data - Expected speedup: 10-100x depending on data volume Co-Authored-By: Claude Sonnet 4.5 --- VBA/Modules/BIPUploadModule.bas | 192 +++++++++++++++++--------------- VBA/Modules/MainModule.bas | 169 +++++++++++++++++----------- 2 files changed, 211 insertions(+), 150 deletions(-) diff --git a/VBA/Modules/BIPUploadModule.bas b/VBA/Modules/BIPUploadModule.bas index 4884801..1b5b1ee 100644 --- a/VBA/Modules/BIPUploadModule.bas +++ b/VBA/Modules/BIPUploadModule.bas @@ -74,9 +74,9 @@ Public Sub ProcessOrdersToBIP() Exit Sub End If - ' 处理每个订单 - Dim outputRow As Long - outputRow = 2 ' 从第2行开始输出（第1行是表头） + ' 处理每个订单，收集所有输出数据 + Dim outputData As collection + Set outputData = New collection Dim i As Long Dim processedCount As Long @@ -122,14 +122,19 @@ Public Sub ProcessOrdersToBIP() orderCount = orderCount + 1 - ' 处理单个订单 - outputRow = ProcessSingleOrder(orderNumber, productModel, quantity, productCode, _ - componentPriority, BomExtractor, bipSheet, outputRow) + ' 处理单个订单，收集输出数据 + ProcessSingleOrder orderNumber, productModel, quantity, productCode, _ + componentPriority, BomExtractor, outputData processedCount = processedCount + 1 ContinueLoop: Next i + ' 批量写入数据到工作表 + If outputData.Count > 0 Then + WriteBatchData bipSheet, outputData + End If + ' 格式化BIP上传模板 FormatBIPSheet bipSheet @@ -138,7 +143,7 @@ ContinueLoop: MsgBox "处理完成!" & vbCrLf & _ "处理订单数: " & orderCount & vbCrLf & _ - "生成BIP行数: " & (outputRow - 2) & vbCrLf & _ + "生成BIP行数: " & outputData.Count & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation ' 激活BIP上传模板 @@ -151,31 +156,25 @@ ErrorHandler: End Sub '===================================================================== -' 函数: ProcessSingleOrder -' 功能: 处理单个订单，提取BOM并写入BIP上传模板 +' 过程: ProcessSingleOrder +' 功能: 处理单个订单，提取BOM并将数据添加到输出集合 ' 参数: orderNumber - 生产订单号 ' productModel - 产品型号 ' quantity - 生产数量 ' productCode - 产品编码 ' componentPriority - 部件优先标志（"是"或"否"） ' BomExtractor - BOM提取器对象 -' bipSheet - BIP上传模板工作表 -' startRow - 起始行号 -' 返回: Long - 下一个可用行号 +' outputData - 输出数据集合 '===================================================================== -Private Function ProcessSingleOrder(orderNumber As String, _ - productModel As String, _ - quantity As String, _ - productCode As String, _ - componentPriority As String, _ - BomExtractor As BomExtractor, _ - bipSheet As Worksheet, _ - startRow As Long) As Long +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 - Dim currentRow As Long - currentRow = startRow - ' 根据部件优先设置排除类别 BomExtractor.ClearExcludeCategories If UCase(componentPriority) = "否" Or componentPriority = "0" Or componentPriority = "FALSE" Then @@ -192,12 +191,10 @@ Private Function ProcessSingleOrder(orderNumber As String, _ extractNote = "" If Not parser.Parse(productModel) Then - ' 解析失败，写入一行错误记录 + ' 解析失败，添加一行错误记录 extractNote = "解析失败: " & parser.ErrorMessage - WriteBIPRow bipSheet, currentRow, orderNumber, productCode, quantity, _ - 1, "", extractNote - ProcessSingleOrder = currentRow + 1 - Exit Function + outputData.Add CreateBIPRowArray(orderNumber, productCode, quantity, 1, "", extractNote) + Exit Sub End If ' 提取BOM @@ -213,13 +210,11 @@ Private Function ProcessSingleOrder(orderNumber As String, _ ' 输出结果 If matchedItems.Count = 0 Then - ' 没有匹配项，写入一行空记录 + ' 没有匹配项，添加一行空记录 If extractNote = "" Then extractNote = "未匹配到任何物料" End If - WriteBIPRow bipSheet, currentRow, orderNumber, productCode, quantity, _ - 1, "", extractNote - currentRow = currentRow + 1 + outputData.Add CreateBIPRowArray(orderNumber, productCode, quantity, 1, "", extractNote) Else ' 输出每个匹配的物料 Dim item As BomItem @@ -236,18 +231,90 @@ Private Function ProcessSingleOrder(orderNumber As String, _ itemNote = itemNote & item.MatchError End If - ' 写入BIP行 - WriteBIPRow bipSheet, currentRow, orderNumber, productCode, quantity, _ - lineIndex, item.Code66, itemNote + ' 创建BIP行数据并添加到集合 + outputData.Add CreateBIPRowArray(orderNumber, productCode, quantity, _ + lineIndex, item.Code66, itemNote) - currentRow = currentRow + 1 lineIndex = lineIndex + 1 Next item End If +End Sub - ProcessSingleOrder = currentRow +'===================================================================== +' 函数: CreateBIPRowArray +' 功能: 创建BIP上传模板一行数据的数组 +' 参数: orderNumber - 生产订单号 +' productCode - 产品编码 +' quantity - 生产数量 +' lineIndex - 行号索引（从1开始） +' materialCode - 材料编码（66编码） +' note - 备注 +' 返回: Variant() - 包含10个元素的数组 +'===================================================================== +Private Function CreateBIPRowArray(orderNumber As String, _ + productCode As String, _ + quantity As String, _ + lineIndex As Long, _ + materialCode As String, _ + note As String) As Variant() + Dim rowData(1 To 10) As Variant + + rowData(1) = orderNumber ' 来源单据号（生产订单号） + rowData(2) = productCode ' 产品编码 + rowData(3) = quantity ' 生产数量 + rowData(4) = ROW_NUMBER_BASE + lineIndex ' 行号 = 基数 + 索引 + rowData(5) = materialCode ' 材料编码（66编码） + rowData(6) = "一般发料" ' 供应方式（固定值） + rowData(7) = Date ' 需用日期（当天日期） + rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值） + rowData(9) = quantity ' 计划出库数量（与生产数量一致） + rowData(10) = note ' 备注 + + 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 10) + + ' 填充数据到二维数组 + 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) + resultData(i, 10) = rowArray(10) + Next i + + ' 一次性写入工作表（从第2行开始） + ws.Range("A2").Resize(rowCount, 10).value = resultData +End Sub + '===================================================================== ' 过程: WriteBIPHeader ' 功能: 写入BIP上传模板表头 @@ -267,57 +334,6 @@ Private Sub WriteBIPHeader(ws As Worksheet) ws.Cells(1, 10).value = "备注" End Sub -'===================================================================== -' 过程: WriteBIPRow -' 功能: 写入BIP上传模板数据行 -' 参数: ws - 工作表对象 -' row - 行号 -' orderNumber - 生产订单号 -' productCode - 产品编码 -' quantity - 生产数量 -' lineIndex - 行号索引（从1开始） -' materialCode - 材料编码（66编码） -' note - 备注 -'===================================================================== -Private Sub WriteBIPRow(ws As Worksheet, _ - row As Long, _ - orderNumber As String, _ - productCode As String, _ - quantity As String, _ - lineIndex As Long, _ - materialCode As String, _ - note As String) - ' 列1：来源单据号（生产订单号） - ws.Cells(row, 1).value = orderNumber - - ' 列2：产品编码 - ws.Cells(row, 2).value = productCode - - ' 列3：生产数量 - ws.Cells(row, 3).value = quantity - - ' 列4：行号 = 基数 + 索引 - ws.Cells(row, 4).value = ROW_NUMBER_BASE + lineIndex - - ' 列5：材料编码（66编码） - ws.Cells(row, 5).value = materialCode - - ' 列6：供应方式（固定值） - ws.Cells(row, 6).value = "一般发料" - - ' 列7：需用日期（当天日期） - ws.Cells(row, 7).value = Date - - ' 列8：发料组织（固定值） - ws.Cells(row, 8).value = "重庆布莱迪仪器仪表有限公司" - - ' 列9：计划出库数量（与生产数量一致） - ws.Cells(row, 9).value = quantity - - ' 列10：备注 - ws.Cells(row, 10).value = note -End Sub - '===================================================================== ' 函数: GetOrderSheet ' 功能: 获取[产品订单]工作表 diff --git a/VBA/Modules/MainModule.bas b/VBA/Modules/MainModule.bas index ce89067..df52e7f 100644 --- a/VBA/Modules/MainModule.bas +++ b/VBA/Modules/MainModule.bas @@ -60,12 +60,13 @@ Public Sub ProcessProductModels() Dim lastRow As Long lastRow = inputSheet.Cells(inputSheet.Rows.Count, 1).End(xlUp).row - Dim outputRow As Long - outputRow = 2 ' 从第2行开始输出(第1行是表头) - ' 写入输出表头 WriteOutputHeader outputSheet + ' 收集所有输出数据 + Dim outputData As collection + Set outputData = New collection + Dim i As Long Dim modelString As String Dim processedCount As Long @@ -79,12 +80,17 @@ Public Sub ProcessProductModels() componentPriority = Trim(inputSheet.Cells(i, 5).value) ' E列：部件优先 If modelString <> "" Then - ' 处理单个型号 - outputRow = ProcessSingleModel(modelString, componentPriority, BomExtractor, outputSheet, outputRow) + ' 处理单个型号，收集数据 + ProcessSingleModel modelString, componentPriority, BomExtractor, outputData processedCount = processedCount + 1 End If Next i + ' 批量写入数据到工作表 + If outputData.Count > 0 Then + WriteBatchData outputSheet, outputData + End If + ' 格式化输出表 FormatOutputSheet outputSheet @@ -105,25 +111,19 @@ ErrorHandler: End Sub '===================================================================== -' 函数: ProcessSingleModel -' 功能: 处理单个产品型号 +' 过程: ProcessSingleModel +' 功能: 处理单个产品型号，将数据添加到输出集合 ' 参数: modelString - 产品型号字符串 ' componentPriority - 部件优先标志（"是"或"否"） ' bomExtractor - BOM提取器对象 -' outputSheet - 输出工作表 -' startRow - 起始行号 -' 返回: Long - 下一个可用行号 +' outputData - 输出数据集合 '===================================================================== -Private Function ProcessSingleModel(modelString As String, _ - componentPriority As String, _ - BomExtractor As BomExtractor, _ - outputSheet As Worksheet, _ - startRow As Long) As Long +Private Sub ProcessSingleModel(modelString As String, _ + componentPriority As String, _ + BomExtractor As BomExtractor, _ + outputData As collection) On Error Resume Next - Dim currentRow As Long - currentRow = startRow - ' 根据部件优先设置排除类别 BomExtractor.ClearExcludeCategories If UCase(componentPriority) = "否" Or componentPriority = "0" Or componentPriority = "FALSE" Then @@ -142,9 +142,8 @@ Private Function ProcessSingleModel(modelString As String, _ If Not parser.Parse(modelString) Then ' 解析失败 extractNote = "解析失败: " & parser.ErrorMessage - WriteOutputRow outputSheet, currentRow, modelString, "", parser.Conditions, extractNote, Nothing - ProcessSingleModel = currentRow + 1 - Exit Function + outputData.Add CreateOutputRowArray(modelString, "", parser.Conditions, extractNote, Nothing) + Exit Sub End If ' 提取BOM @@ -164,8 +163,7 @@ Private Function ProcessSingleModel(modelString As String, _ If extractNote = "" Then extractNote = "未匹配到任何物料" End If - WriteOutputRow outputSheet, currentRow, modelString, parser.HeaderModel, parser.Conditions, extractNote, Nothing - currentRow = currentRow + 1 + outputData.Add CreateOutputRowArray(modelString, parser.HeaderModel, parser.Conditions, extractNote, Nothing) Else ' 输出每个匹配的物料 Dim item As BomItem @@ -183,18 +181,14 @@ Private Function ProcessSingleModel(modelString As String, _ End If If isFirst Then - WriteOutputRow outputSheet, currentRow, modelString, parser.HeaderModel, parser.Conditions, itemNote, item + outputData.Add CreateOutputRowArray(modelString, parser.HeaderModel, parser.Conditions, itemNote, item) isFirst = False Else - WriteOutputRow outputSheet, currentRow, "", "", parser.Conditions, itemNote, item + outputData.Add CreateOutputRowArray("", "", parser.Conditions, itemNote, item) End If - - currentRow = currentRow + 1 Next item End If - - ProcessSingleModel = currentRow -End Function +End Sub '===================================================================== ' 过程: WriteOutputHeader @@ -231,58 +225,109 @@ Private Sub WriteOutputHeader(ws As Worksheet) End Sub '===================================================================== -' 过程: WriteOutputRow -' 功能: 写入输出行 -' 参数: ws - 工作表对象 -' row - 行号 -' fullModel - 完整型号 -' headerModel - 表头型号 -' conditions - 条件字典 +' 函数: CreateOutputRowArray +' 功能: 创建输出行数据的数组 +' 参数: FullModel - 完整型号 +' HeaderModel - 表头型号 +' Conditions - 条件字典 ' note - 备注 ' item - BOM项(可为Nothing) +' 返回: Variant() - 行数据数组 '===================================================================== -Private Sub WriteOutputRow(ws As Worksheet, _ - row As Long, _ - FullModel As String, _ - HeaderModel As String, _ - Conditions As Object, _ - note As String, _ - item As BomItem) - Dim col As Long - col = 1 - - ws.Cells(row, col).value = FullModel: col = col + 1 - ws.Cells(row, col).value = HeaderModel: col = col + 1 - - ' 写入条件值 +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 - ws.Cells(row, col).value = Conditions(condNames(i)) + rowData(col) = Conditions(condNames(i)) Else - ws.Cells(row, col).value = "" + rowData(col) = "" End If col = col + 1 Next i ' 写入BOM数据 If Not item Is Nothing Then - ws.Cells(row, col).value = item.RowNumber: col = col + 1 - ws.Cells(row, col).value = item.Module: col = col + 1 - ws.Cells(row, col).value = item.code: col = col + 1 - ws.Cells(row, col).value = item.Name: col = col + 1 - ws.Cells(row, col).value = item.Quantity: col = col + 1 - ws.Cells(row, col).value = item.category: col = col + 1 - ws.Cells(row, col).value = item.Code66: col = col + 1 + 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 - col = col + 7 ' 跳过BOM字段 + ' 跳过BOM字段 + col = col + 7 End If - ws.Cells(row, col).value = note + ' 备注 + 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 '=====================================================================