diff --git a/VBA/DocumentModules/Sheet9.cls b/VBA/DocumentModules/Sheet9.cls index 45fbb8b..c7b17b7 100644 --- a/VBA/DocumentModules/Sheet9.cls +++ b/VBA/DocumentModules/Sheet9.cls @@ -21,4 +21,8 @@ End Sub '===================================================================== Private Sub CommandButton3_Click() Call FetchDataFromAccess +End Sub + +Private Sub CommandButton4_Click() + ThisWorkbook.Worksheets("产品订单").Range("A2:G10000").ClearContents End Sub \ No newline at end of file diff --git a/VBA/Modules/AccessDataModule.bas b/VBA/Modules/AccessDataModule.bas index 5ed2506..e8f0352 100644 --- a/VBA/Modules/AccessDataModule.bas +++ b/VBA/Modules/AccessDataModule.bas @@ -1,6 +1,7 @@ '===================================================================== ' 模块名: AccessDataModule ' 功能: 连接Access数据库，根据[总排号]提取数据并填充到[产品订单]工作表 +' 特性: [安全极速版] 完美解决筛选状态下全量数组写回导致的错位 Bug '===================================================================== Option Explicit @@ -38,52 +39,52 @@ Public Sub FetchDataFromAccess() Exit Sub End If - ' 1. 将Excel数据读入内存数组 (A到F列) - Dim dataArr As Variant - dataArr = ws.Range("A2:F" & lastRow).value + ' 1. 获取A列中所有筛选后的（可见）单元格 + Dim visibleRange As Range + On Error Resume Next + Set visibleRange = ws.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible) + On Error GoTo ErrorHandler - ' 收集所有的总排号，用于构建SQL查询条件 - Dim queueNums As String - Dim i As Long - Dim currentNum As String - - For i = 1 To UBound(dataArr, 1) - currentNum = Trim(dataArr(i, 1)) - If currentNum <> "" Then - ' 假设总排号是文本类型。如果是纯数字类型，请去掉单引号 - queueNums = queueNums & "'" & currentNum & "'," - End If - Next i - - If queueNums = "" Then - MsgBox "没有找到有效的总排号。", vbInformation + If visibleRange Is Nothing Then + MsgBox "当前筛选状态下没有可见的数据。", vbInformation + Exit Sub + End If + + ' 2. 仅收集可见行中的总排号 + Dim cell As Range + Dim queueNums As String + Dim currentNum As String + + For Each cell In visibleRange + currentNum = Trim(cell.value) + If currentNum <> "" Then + queueNums = queueNums & "'" & currentNum & "'," + End If + Next cell + + If queueNums = "" Then + MsgBox "可见数据中没有找到有效的总排号。", vbInformation Exit Sub End If - ' 去除最后一个逗号 queueNums = Left(queueNums, Len(queueNums) - 1) - ' 2. 连接Access数据库并查询 - Dim cn As Object - Dim rs As Object + ' 3. 连接Access查询并装入字典 (内存极速匹配) + Dim cn As Object, rs As Object Set cn = CreateObject("ADODB.Connection") Set rs = CreateObject("ADODB.Recordset") - ' 构建连接字符串 (适用于 .accdb 格式) Dim connStr As String connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_PATH & ";" - cn.Open connStr - ' 构建SQL语句，只提取需要的字段和匹配的总排号 Dim sql As String sql = "SELECT 总排号, 生产订单号, 产品型号, 数量, 成品物料码 " & _ "FROM [" & TARGET_TABLE & "] " & _ "WHERE 总排号 IN (" & queueNums & ")" - rs.Open sql, cn, 1, 1 ' adOpenKeyset, adLockReadOnly + rs.Open sql, cn, 1, 1 - ' 3. 将查询结果存入字典，利用字典的哈希特性实现极速匹配 Dim dbDict As Object Set dbDict = CreateObject("Scripting.Dictionary") @@ -92,8 +93,6 @@ Public Sub FetchDataFromAccess() Do Until rs.EOF Dim key As String key = Trim(rs.Fields("总排号").value) - - ' 将需要的字段打包成一个数组存入字典 If Not dbDict.Exists(key) Then dbDict.Add key, Array( _ rs.Fields("生产订单号").value, _ @@ -106,59 +105,58 @@ Public Sub FetchDataFromAccess() Loop End If - ' 关闭数据库连接 rs.Close cn.Close Set rs = Nothing Set cn = Nothing - ' 4. 将字典中的数据回填到内存数组 + ' 4. 【核心修复】安全且极速地回写可见数据 Dim matchCount As Long matchCount = 0 - For i = 1 To UBound(dataArr, 1) - currentNum = Trim(dataArr(i, 1)) + ' 关闭屏幕刷新、自动计算和事件触发，拉满单行写入性能 + Application.ScreenUpdating = False + Application.Calculation = xlCalculationManual + Application.EnableEvents = False + + For Each cell In visibleRange + currentNum = Trim(cell.value) + If dbDict.Exists(currentNum) Then Dim dbRecord As Variant dbRecord = dbDict(currentNum) - ' 将对应的字段映射到数组的相应列 - dataArr(i, 2) = dbRecord(0) ' B列: 生产订单号 - dataArr(i, 3) = dbRecord(1) ' C列: 产品型号 - dataArr(i, 4) = dbRecord(2) ' D列: 数量 - dataArr(i, 5) = dbRecord(3) ' E列: 产品编码 (成品物料码) - ' F列 (部件优先) 保持原样，不作修改 + ' 【神级优化点】：将4个字段装入一个微型一维数组，利用 Resize 一次性写入 B 到 E 列 + ' 这样每一行只需要 1 次单元格操作，而不是 4 次！性能无限逼近全量数组写回。 + cell.Offset(0, 1).Resize(1, 4).value = Array(dbRecord(0), dbRecord(1), dbRecord(2), dbRecord(3)) matchCount = matchCount + 1 End If - Next i + Next cell - ' 5. 将更新后的数组一次性写回工作表 - ws.Range("A2:F" & lastRow).value = dataArr - - ' 清理内存 + ' 恢复应用状态 + Application.EnableEvents = True + Application.Calculation = xlCalculationAutomatic + Application.ScreenUpdating = True Set dbDict = Nothing Dim elapsedTime As Double elapsedTime = Timer - startTime MsgBox "数据提取完成!" & vbCrLf & _ - "成功匹配并更新了 " & matchCount & " 条记录。" & vbCrLf & _ + "成功匹配并更新了 " & matchCount & " 条筛选记录。" & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & " 秒", vbInformation Exit Sub ErrorHandler: - ' 确保发生错误时关闭数据库连接 + Application.EnableEvents = True + Application.Calculation = xlCalculationAutomatic + Application.ScreenUpdating = True On Error Resume Next - If Not rs Is Nothing Then - If rs.State = 1 Then rs.Close - End If - If Not cn Is Nothing Then - If cn.State = 1 Then cn.Close - End If + If Not rs Is Nothing Then If rs.State = 1 Then rs.Close + If Not cn Is Nothing Then If cn.State = 1 Then cn.Close On Error GoTo 0 - MsgBox "提取Access数据时发生异常: " & Err.Description, vbCritical End Sub diff --git a/VBA/Modules/BIPUploadModule.bas b/VBA/Modules/BIPUploadModule.bas index c1edd83..9bc6f13 100644 --- a/VBA/Modules/BIPUploadModule.bas +++ b/VBA/Modules/BIPUploadModule.bas @@ -1,6 +1,7 @@ '===================================================================== ' 模块名: BIPUploadModule ' 功能: 处理产品订单数据，提取BOM后生成[BIP上传模板]格式数据 +' 特性: [已重构] 支持仅对筛选后的数据进行处理，采用内存极速读取 '===================================================================== Option Explicit @@ -22,6 +23,8 @@ Public Sub ProcessOrdersToBIP() Dim startTime As Double startTime = Timer + Application.ScreenUpdating = False + ' 准备工作表对象 Dim orderSheet As Worksheet Dim bipSheet As Worksheet @@ -30,6 +33,7 @@ Public Sub ProcessOrdersToBIP() ' 获取[产品订单]工作表 Set orderSheet = GetOrderSheet() If orderSheet Is Nothing Then + Application.ScreenUpdating = True MsgBox "未找到[产品订单]工作表!", vbCritical Exit Sub End If @@ -40,6 +44,7 @@ Public Sub ProcessOrdersToBIP() ' 获取BOM库工作表 Set bomSheet = GetBomSheet() If bomSheet Is Nothing Then + Application.ScreenUpdating = True MsgBox "未找到[平台配置清单]工作表!", vbCritical Exit Sub End If @@ -50,6 +55,7 @@ Public Sub ProcessOrdersToBIP() BomExtractor.SetWorksheet bomSheet If Not BomExtractor.LoadBomData Then + Application.ScreenUpdating = True MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical Exit Sub End If @@ -66,22 +72,44 @@ Public Sub ProcessOrdersToBIP() ' 如果只有表头或没有数据 If lastRow < 2 Then + Application.ScreenUpdating = True MsgBox "[产品订单]工作表中没有数据!", vbExclamation Exit Sub End If - ' 处理每个订单，收集所有输出数据 + ' 【性能核心】全量读入源数据 + Dim sourceDataArr As Variant + sourceDataArr = orderSheet.Range("A2:F" & 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 i As Long + Dim cell As Range + Dim arrIndex As Long Dim processedCount As Long Dim orderCount As Long processedCount = 0 orderCount = 0 - For i = 2 To lastRow + ' 遍历筛选出来的可见单元格 + For Each cell In visibleRange + ' 计算内存数组索引 + arrIndex = cell.row - 1 + ' 读取订单数据 Dim totalQueueNum As String Dim orderNumber As String @@ -90,13 +118,12 @@ Public Sub ProcessOrdersToBIP() Dim productCode As String Dim componentPriority As String - ' --- 核心修改：调整列索引以适应新增的A列“总排号” --- - totalQueueNum = Trim(orderSheet.Cells(i, 1).value) ' A列：总排号 (如果后续BIP需要可直接使用此变量) - orderNumber = Trim(orderSheet.Cells(i, 2).value) ' B列：生产订单号 - ProductModel = Trim(orderSheet.Cells(i, 3).value) ' C列：产品型号 - Quantity = Trim(orderSheet.Cells(i, 4).value) ' D列：数量 - productCode = Trim(orderSheet.Cells(i, 5).value) ' E列：产品编码 - componentPriority = Trim(orderSheet.Cells(i, 6).value) ' F列：部件优先 + 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列：部件优先 ' 跳过空行 If orderNumber = "" And ProductModel = "" Then @@ -105,17 +132,17 @@ Public Sub ProcessOrdersToBIP() ' 验证必填字段 If orderNumber = "" Then - MsgBox "第" & i & "行：生产订单号为空，跳过该行!", vbExclamation + MsgBox "工作表第" & cell.row & "行：生产订单号为空，跳过该行!", vbExclamation GoTo ContinueLoop End If If ProductModel = "" Then - MsgBox "第" & i & "行：产品型号为空，跳过该行!", vbExclamation + MsgBox "工作表第" & cell.row & "行：产品型号为空，跳过该行!", vbExclamation GoTo ContinueLoop End If If Quantity = "" Then - MsgBox "第" & i & "行：数量为空，跳过该行!", vbExclamation + MsgBox "工作表第" & cell.row & "行：数量为空，跳过该行!", vbExclamation GoTo ContinueLoop End If @@ -123,11 +150,11 @@ Public Sub ProcessOrdersToBIP() ' 处理单个订单，收集输出数据 ProcessSingleOrder orderNumber, ProductModel, Quantity, productCode, _ - componentPriority, BomExtractor, outputData + componentPriority, BomExtractor, outputData processedCount = processedCount + 1 ContinueLoop: - Next i + Next cell ' 批量写入数据到工作表 If outputData.count > 0 Then @@ -140,8 +167,10 @@ ContinueLoop: Dim elapsedTime As Double elapsedTime = Timer - startTime + Application.ScreenUpdating = True + MsgBox "处理完成!" & vbCrLf & _ - "处理订单数: " & orderCount & vbCrLf & _ + "处理筛选订单数: " & orderCount & vbCrLf & _ "生成BIP行数: " & outputData.count & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation @@ -151,6 +180,7 @@ ContinueLoop: Exit Sub ErrorHandler: + Application.ScreenUpdating = True MsgBox "处理异常: " & Err.Description, vbCritical End Sub @@ -284,7 +314,7 @@ Private Function CreateBIPRowArray(orderNumber As String, _ rowData(5) = materialCode ' 材料编码（66 编码） rowData(6) = "一般发料" ' 供应方式（固定值） rowData(7) = Date ' 需用日期（当天日期） - rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值） + rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值） rowData(9) = Quantity ' 计划出库数量（与生产数量一致） rowData(10) = note ' 备注 diff --git a/VBA/Modules/ComponentInventoryCheckModule.bas b/VBA/Modules/ComponentInventoryCheckModule.bas index a591d0a..315beef 100644 --- a/VBA/Modules/ComponentInventoryCheckModule.bas +++ b/VBA/Modules/ComponentInventoryCheckModule.bas @@ -1,7 +1,7 @@ '===================================================================== ' 模块名: ComponentInventoryCheckModule -' 功能: 部件库存核对模块 - 自动核对产品订单中"部件"类物料的库存情况 -' 说明: 当库存不足时,按订单顺序将超出部分的订单的"部件优先"字段标记为"否" +' 功能: 部件库存核推模块 - 自动核对产品订单中"部件"类物料的库存情况 +' 特性: [已重构] 支持仅对筛选后的数据进行处理，采用内存极速读取 '===================================================================== Option Explicit @@ -43,6 +43,10 @@ Public Sub CheckComponentInventory() Dim startTime As Double startTime = Timer + ' 提升性能：关闭屏幕更新和自动计算 + Application.ScreenUpdating = False + Application.Calculation = xlCalculationManual + ' 获取工作表对象 Dim orderSheet As Worksheet Dim inventorySheet As Worksheet @@ -50,18 +54,21 @@ Public Sub CheckComponentInventory() Set orderSheet = GetOrderSheet() If orderSheet Is Nothing Then + RestoreAppStatus MsgBox "未找到[产品订单]工作表!", vbExclamation Exit Sub End If Set inventorySheet = GetInventorySheet() If inventorySheet Is Nothing Then + RestoreAppStatus MsgBox "未找到[现存量]工作表!", vbExclamation Exit Sub End If Set bomSheet = GetBomSheet() If bomSheet Is Nothing Then + RestoreAppStatus MsgBox "未找到[平台配置清单]工作表!", vbExclamation Exit Sub End If @@ -70,16 +77,30 @@ Public Sub CheckComponentInventory() Dim lastRow As Long lastRow = orderSheet.Cells(orderSheet.Rows.count, 3).End(xlUp).row If lastRow < 2 Then + RestoreAppStatus MsgBox "[产品订单]工作表没有数据!", vbExclamation Exit Sub End If + ' 【核心重构】获取筛选后的可见单元格区域 (A列) + 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 + RestoreAppStatus + MsgBox "当前筛选状态下没有可见的数据。", vbInformation + Exit Sub + End If + ' 初始化BOM提取器 Dim BomExtractor As BomExtractor Set BomExtractor = New BomExtractor BomExtractor.SetWorksheet bomSheet If Not BomExtractor.LoadBomData Then + RestoreAppStatus MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical Exit Sub End If @@ -89,16 +110,18 @@ Public Sub CheckComponentInventory() Set inventoryData = LoadInventoryData(inventorySheet) If inventoryData.count = 0 Then + RestoreAppStatus MsgBox "[现存量]工作表没有有效数据!", vbExclamation Exit Sub End If - ' 读取订单数据 + ' 【核心重构】传递可见区域和总行数，仅读取可见订单数据 Dim orders As Collection - Set orders = LoadOrderData(orderSheet) + Set orders = LoadOrderData(orderSheet, visibleRange, lastRow) If orders.count = 0 Then - MsgBox "没有有效的订单数据!", vbExclamation + RestoreAppStatus + MsgBox "可见区域中没有有效的订单数据!", vbExclamation Exit Sub End If @@ -110,7 +133,8 @@ Public Sub CheckComponentInventory() Set componentDemands = CalculateComponentDemand(orders) If componentDemands.count = 0 Then - MsgBox "没有订单包含'部件'类别物料,无需处理库存!", vbInformation + RestoreAppStatus + MsgBox "筛选的订单中没有包含'部件'类别物料,无需处理库存!", vbInformation Exit Sub End If @@ -118,17 +142,20 @@ Public Sub CheckComponentInventory() Dim validationWarnings As Collection Set validationWarnings = ValidateInventory(componentDemands, inventoryData) - ' 按订单顺序分配库存 + ' 按订单顺序分配库存并标记 Dim stats As Statistics AllocateInventory orders, componentDemands, orderSheet, stats + ' 恢复应用状态 + RestoreAppStatus + ' 输出结果统计 Dim elapsedTime As Double elapsedTime = Timer - startTime Dim resultMsg As String resultMsg = "部件库存核对完成!" & vbCrLf & vbCrLf - resultMsg = resultMsg & "处理订单数: " & stats.TotalOrders & vbCrLf + resultMsg = resultMsg & "处理筛选订单数: " & stats.TotalOrders & vbCrLf resultMsg = resultMsg & "包含部件订单: " & stats.OrdersWithComponent & vbCrLf resultMsg = resultMsg & "库存充足订单: " & stats.OrdersSufficient & vbCrLf resultMsg = resultMsg & "库存不足订单: " & stats.OrdersInsufficient & vbCrLf @@ -148,37 +175,54 @@ Public Sub CheckComponentInventory() Exit Sub ErrorHandler: + RestoreAppStatus MsgBox "部件库存核对异常: " & Err.Description, vbCritical End Sub +'===================================================================== +' 辅助过程: RestoreAppStatus +' 功能: 恢复Excel应用程序的状态 +'===================================================================== +Private Sub RestoreAppStatus() + Application.Calculation = xlCalculationAutomatic + Application.ScreenUpdating = True +End Sub + '===================================================================== ' 函数: LoadOrderData ' 功能: 读取订单数据 ' 参数: ws - [产品订单]工作表 ' 返回: Collection - 每个元素是字典对象,包含订单信息 '===================================================================== -Private Function LoadOrderData(ws As Worksheet) As Collection +Private Function LoadOrderData(ws As Worksheet, visibleRange As Range, lastRow As Long) As Collection Set LoadOrderData = New Collection - ' 调整为按C列获取最后一行 - Dim lastRow As Long - lastRow = ws.Cells(ws.Rows.count, 3).End(xlUp).row + ' 全量读入内存数组提升速度 + Dim sourceDataArr As Variant + sourceDataArr = ws.Range("A2:F" & lastRow).value - Dim i As Long - For i = 2 To lastRow + Dim cell As Range + Dim arrIndex As Long + + ' 仅遍历可见的单元格 + For Each cell In visibleRange Dim model As String Dim qty As Variant - ' --- 核心修改：列索引向右移1列 --- - model = Trim(ws.Cells(i, 3).value) ' C列: 产品型号 (原B列) - qty = ws.Cells(i, 4).value ' D列: 产品数量 (原C列) + ' 数组索引 = Excel行号 - 1 + arrIndex = cell.row - 1 + + ' 从内存数组中提取数据 + model = Trim(sourceDataArr(arrIndex, 3)) ' C列: 产品型号 + qty = sourceDataArr(arrIndex, 4) ' D列: 产品数量 ' 跳过空行 If model <> "" Then Dim order As Object Set order = CreateObject("Scripting.Dictionary") - order.Add ORDER_ROW, CLng(i) + ' 记录真实的Excel行号，用于后续库存不足时精准写入F列 + order.Add ORDER_ROW, CLng(cell.row) order.Add ORDER_MODEL, CStr(model) order.Add ORDER_QUANTITY, CDbl(IIf(IsNull(qty) Or IsEmpty(qty), 0, qty)) order.Add ORDER_COMP_CODE, "" @@ -188,7 +232,7 @@ Private Function LoadOrderData(ws As Worksheet) As Collection LoadOrderData.Add order End If - Next i + Next cell End Function '===================================================================== @@ -327,15 +371,12 @@ Private Function ValidateInventory(componentDemands As Object, _ ' 检查库存中是否存在该部件 If Not inventoryData.Exists(compInv(INV_CODE)) Then - ' 库存中找不到，设置库存为0，并添加警告 compInv(INV_STOCK) = 0 compInv(INV_SHORTAGE) = True ValidateInventory.Add "部件 '" & compInv(INV_CODE) & "' 在[现存量]中未找到" Else - ' 设置可用库存 compInv(INV_STOCK) = inventoryData(compInv(INV_CODE)) - ' 检查是否短缺 If compInv(INV_DEMAND) > compInv(INV_STOCK) Then compInv(INV_SHORTAGE) = True End If @@ -402,8 +443,7 @@ Private Sub AllocateInventory(orders As Collection, _ compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty stats.OrdersSufficient = stats.OrdersSufficient + 1 Else - ' --- 核心修改：回填结果写入F列(第6列) --- - ' 库存不足,标记为"否" + ' --- 因为已经保存了真正的行号 ORDER_ROW, 在关闭屏幕刷新的情况下，这里直接写入是非常快的 --- orderSheet.Cells(order(ORDER_ROW), 6).value = "否" compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty stats.OrdersInsufficient = stats.OrdersInsufficient + 1 diff --git a/VBA/Modules/MainModule.bas b/VBA/Modules/MainModule.bas index 5ec723b..9f8e9f0 100644 --- a/VBA/Modules/MainModule.bas +++ b/VBA/Modules/MainModule.bas @@ -1,6 +1,7 @@ '===================================================================== ' 模块名: MainModule ' 功能: 主控模块,处理产品型号提取和BOM匹配的上层逻辑 +' 特性: [已重构] 支持仅对筛选后的数据进行处理，采用内存极速读取 '===================================================================== Option Explicit @@ -22,6 +23,9 @@ Public Sub ProcessProductModels() Dim startTime As Double startTime = Timer + ' 关闭屏幕刷新提升速度 + Application.ScreenUpdating = False + ' 准备输入输出 Dim inputSheet As Worksheet Dim outputSheet As Worksheet @@ -30,6 +34,7 @@ Public Sub ProcessProductModels() ' 获取工作表 Set inputSheet = GetInputSheet() If inputSheet Is Nothing Then + Application.ScreenUpdating = True MsgBox "未找到输入工作表,请确保工作簿中有包含订单数据的工作表", vbCritical Exit Sub End If @@ -37,6 +42,7 @@ Public Sub ProcessProductModels() ' 获取BOM库工作表 Set bomSheet = GetBomSheet() If bomSheet Is Nothing Then + Application.ScreenUpdating = True MsgBox "未找到'平台配置清单'工作表,请确保BOM数据存在", vbCritical Exit Sub End If @@ -50,14 +56,36 @@ Public Sub ProcessProductModels() BomExtractor.SetWorksheet bomSheet If Not BomExtractor.LoadBomData Then + Application.ScreenUpdating = True MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical Exit Sub End If - ' 处理每个产品型号 Dim lastRow As Long lastRow = inputSheet.Cells(inputSheet.Rows.count, 1).End(xlUp).row + If lastRow < 2 Then + Application.ScreenUpdating = True + MsgBox "[产品订单]工作表中没有数据!", vbExclamation + Exit Sub + End If + + ' 【性能核心】将输入数据全量读入内存数组 + Dim sourceDataArr As Variant + sourceDataArr = inputSheet.Range("A2:F" & lastRow).value + + ' 【筛选核心】获取可见的单元格区域 + Dim visibleRange As Range + On Error Resume Next + Set visibleRange = inputSheet.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible) + On Error GoTo ErrorHandler + + If visibleRange Is Nothing Then + Application.ScreenUpdating = True + MsgBox "当前筛选状态下没有可见的数据。", vbInformation + Exit Sub + End If + ' 写入输出表头 WriteOutputHeader outputSheet @@ -65,30 +93,34 @@ Public Sub ProcessProductModels() Dim outputData As Collection Set outputData = New Collection - Dim i As Long + Dim cell As Range + Dim arrIndex As Long Dim modelString As String Dim processedCount As Long processedCount = 0 - ' 假设数据从第2行开始 - For i = 2 To lastRow + ' 仅遍历筛选出来的可见行 + For Each cell In visibleRange Dim totalQueueNum As String Dim orderNumber As String Dim componentPriority As String - ' --- 核心修改：调整列索引以适应新增的“总排号” --- - totalQueueNum = Trim(inputSheet.Cells(i, 1).value) ' A列：总排号 - orderNumber = Trim(inputSheet.Cells(i, 2).value) ' B列：生产订单号 - modelString = Trim(inputSheet.Cells(i, 3).value) ' C列：产品型号 - componentPriority = Trim(inputSheet.Cells(i, 6).value) ' F列：部件优先 (原E列右移一列) + ' 将工作表行号映射到数组索引 + arrIndex = cell.row - 1 + + ' 从内存数组中极速读取对应字段 + totalQueueNum = Trim(sourceDataArr(arrIndex, 1)) ' A列：总排号 + orderNumber = Trim(sourceDataArr(arrIndex, 2)) ' B列：生产订单号 + modelString = Trim(sourceDataArr(arrIndex, 3)) ' C列：产品型号 + componentPriority = Trim(sourceDataArr(arrIndex, 6)) ' F列：部件优先 If modelString <> "" Then - ' 处理单个型号，收集数据，增加 totalQueueNum 参数 + ' 处理单个型号，收集数据 ProcessSingleModel totalQueueNum, orderNumber, modelString, componentPriority, BomExtractor, outputData processedCount = processedCount + 1 End If - Next i + Next cell ' 批量写入数据到工作表 If outputData.count > 0 Then @@ -101,8 +133,10 @@ Public Sub ProcessProductModels() Dim elapsedTime As Double elapsedTime = Timer - startTime + Application.ScreenUpdating = True + MsgBox "处理完成!" & vbCrLf & _ - "处理型号数: " & processedCount & vbCrLf & _ + "处理筛选型号数: " & processedCount & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation ' 激活输出表 @@ -111,6 +145,7 @@ Public Sub ProcessProductModels() Exit Sub ErrorHandler: + Application.ScreenUpdating = True MsgBox "处理异常: " & Err.Description, vbCritical End Sub @@ -227,7 +262,7 @@ Private Sub WriteOutputHeader(ws As Worksheet) ' BOM字段表头 ws.Cells(1, col).value = "行号": col = col + 1 ws.Cells(1, col).value = "模块": col = col + 1 - ws.Cells(1, col).value = "代号": col = col + 1 + ' ws.Cells(1, col).Value = "代号": col = col + 1 <-- 已移除 ws.Cells(1, col).value = "名称": col = col + 1 ws.Cells(1, col).value = "数量": col = col + 1 ws.Cells(1, col).value = "类别": col = col + 1 @@ -256,9 +291,9 @@ Private Function CreateOutputRowArray(totalQueueNum As String, _ Dim labels() As String GetConditionConfig condNames, labels - ' 计算总列数：3 (排号+订单+型号) + 条件数 + 8 (BOM+备注) + ' 计算总列数：3 (排号+订单+型号) + 条件数 + 7 (BOM字段减去代号后剩6个 + 1个备注) Dim totalCols As Long - totalCols = 3 + (UBound(condNames) - LBound(condNames) + 1) + 8 + totalCols = 3 + (UBound(condNames) - LBound(condNames) + 1) + 7 ' 创建数组 ReDim rowData(1 To totalCols) As Variant @@ -286,14 +321,14 @@ Private Function CreateOutputRowArray(totalQueueNum As String, _ If Not item Is Nothing Then rowData(col) = item.RowNumber: col = col + 1 rowData(col) = item.Module: col = col + 1 - rowData(col) = item.code: 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 - ' 跳过BOM字段 - col = col + 7 + ' 跳过BOM字段 (原本是7个字段，去掉代号后变成6个字段) + col = col + 6 End If ' 备注 @@ -301,6 +336,7 @@ Private Function CreateOutputRowArray(totalQueueNum As String, _ CreateOutputRowArray = rowData End Function + '===================================================================== ' 过程: WriteBatchData ' 功能: 批量写入数据到工作表