admin/AutoBOM
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: support filtered data processing and optimize performance

Browse Source 
- Add clear data button functionality to Sheet9
- Refactor AccessDataModule to safely handle filtered data with memory array optimization
- Refactor BIPUploadModule to process only visible rows with screen updating optimization
- Refactor ComponentInventoryCheckModule to support filtered data and improve performance
- Refactor MainModule to handle filtered data and remove '代号' field
- Add RestoreAppStatus helper for better application state management
- Improve overall performance by using memory arrays instead of cell-by-cell operations

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
Misaka_Company
2026-03-13 13:12:31 +08:00
parent 596a2d0ad2
commit 36c00befa5
5 changed files with 220 additions and 112 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
VBA/DocumentModules/Sheet9.cls
View File

@@ -21,4 +21,8 @@ End Sub
'===================================================================== '=====================================================================
Private Sub CommandButton3_Click() Private Sub CommandButton3_Click()
Call FetchDataFromAccess Call FetchDataFromAccess
End Sub
Private Sub CommandButton4_Click()
ThisWorkbook.Worksheets("产品订单").Range("A2:G10000").ClearContents
End Sub End Sub

104
VBA/Modules/AccessDataModule.bas
View File

@@ -1,6 +1,7 @@
'===================================================================== '=====================================================================
' 模块名: AccessDataModule ' 模块名: AccessDataModule
' 功能: 连接Access数据库，根据[总排号]提取数据并填充到[产品订单]工作表 ' 功能: 连接Access数据库，根据[总排号]提取数据并填充到[产品订单]工作表
' 特性: [安全极速版] 完美解决筛选状态下全量数组写回导致的错位 Bug
'===================================================================== '=====================================================================
Option Explicit Option Explicit
@@ -38,52 +39,52 @@ Public Sub FetchDataFromAccess()
Exit Sub Exit Sub
End If End If
' 1. 将Excel数据读入内存数组 (A到F列) ' 1. 获取A列中所有筛选后的（可见）单元格
Dim dataArr As Variant Dim visibleRange As Range
dataArr = ws.Range("A2:F" & lastRow).value On Error Resume Next
Set visibleRange = ws.Range("A2:A" & lastRow).SpecialCells(xlCellTypeVisible)
On Error GoTo ErrorHandler
' 收集所有的总排号，用于构建SQL查询条件 If visibleRange Is Nothing Then
Dim queueNums As String MsgBox "当前筛选状态下没有可见的数据。", vbInformation
Dim i As Long Exit Sub
Dim currentNum As String End If
For i = 1 To UBound(dataArr, 1) ' 2. 仅收集可见行中的总排号
currentNum = Trim(dataArr(i, 1)) Dim cell As Range
If currentNum <> "" Then Dim queueNums As String
' 假设总排号是文本类型。如果是纯数字类型，请去掉单引号 Dim currentNum As String
queueNums = queueNums & "'" & currentNum & "',"
End If For Each cell In visibleRange
Next i currentNum = Trim(cell.value)
If currentNum <> "" Then
If queueNums = "" Then queueNums = queueNums & "'" & currentNum & "',"
MsgBox "没有找到有效的总排号。", vbInformation End If
Next cell
If queueNums = "" Then
MsgBox "可见数据中没有找到有效的总排号。", vbInformation
Exit Sub Exit Sub
End If End If
' 去除最后一个逗号
queueNums = Left(queueNums, Len(queueNums) - 1) queueNums = Left(queueNums, Len(queueNums) - 1)
' 2. 连接Access数据库并查询 ' 3. 连接Access查询并装入字典 (内存极速匹配)
Dim cn As Object Dim cn As Object, rs As Object
Dim rs As Object
Set cn = CreateObject("ADODB.Connection") Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset") Set rs = CreateObject("ADODB.Recordset")
' 构建连接字符串 (适用于 .accdb 格式)
Dim connStr As String Dim connStr As String
connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_PATH & ";" connStr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & DB_PATH & ";"
cn.Open connStr cn.Open connStr
' 构建SQL语句，只提取需要的字段和匹配的总排号
Dim sql As String Dim sql As String
sql = "SELECT 总排号, 生产订单号, 产品型号, 数量, 成品物料码 " & _ sql = "SELECT 总排号, 生产订单号, 产品型号, 数量, 成品物料码 " & _
"FROM [" & TARGET_TABLE & "] " & _ "FROM [" & TARGET_TABLE & "] " & _
"WHERE 总排号 IN (" & queueNums & ")" "WHERE 总排号 IN (" & queueNums & ")"
rs.Open sql, cn, 1, 1 ' adOpenKeyset, adLockReadOnly rs.Open sql, cn, 1, 1
' 3. 将查询结果存入字典，利用字典的哈希特性实现极速匹配
Dim dbDict As Object Dim dbDict As Object
Set dbDict = CreateObject("Scripting.Dictionary") Set dbDict = CreateObject("Scripting.Dictionary")
@@ -92,8 +93,6 @@ Public Sub FetchDataFromAccess()
Do Until rs.EOF Do Until rs.EOF
Dim key As String Dim key As String
key = Trim(rs.Fields("总排号").value) key = Trim(rs.Fields("总排号").value)
' 将需要的字段打包成一个数组存入字典
If Not dbDict.Exists(key) Then If Not dbDict.Exists(key) Then
dbDict.Add key, Array( _ dbDict.Add key, Array( _
rs.Fields("生产订单号").value, _ rs.Fields("生产订单号").value, _
@@ -106,59 +105,58 @@ Public Sub FetchDataFromAccess()
Loop Loop
End If End If
' 关闭数据库连接
rs.Close rs.Close
cn.Close cn.Close
Set rs = Nothing Set rs = Nothing
Set cn = Nothing Set cn = Nothing
' 4. 将字典中的数据回填到内存数组 ' 4. 【核心修复】安全且极速地回写可见数据
Dim matchCount As Long Dim matchCount As Long
matchCount = 0 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 If dbDict.Exists(currentNum) Then
Dim dbRecord As Variant Dim dbRecord As Variant
dbRecord = dbDict(currentNum) dbRecord = dbDict(currentNum)
' 将对应的字段映射到数组的相应列 ' 【神级优化点】：将4个字段装入一个微型一维数组，利用 Resize 一次性写入 B 到 E 列
dataArr(i, 2) = dbRecord(0) ' B列: 生产订单号 ' 这样每一行只需要 1 次单元格操作，而不是 4 次！性能无限逼近全量数组写回。
dataArr(i, 3) = dbRecord(1) ' C列: 产品型号 cell.Offset(0, 1).Resize(1, 4).value = Array(dbRecord(0), dbRecord(1), dbRecord(2), dbRecord(3))
dataArr(i, 4) = dbRecord(2) ' D列: 数量
dataArr(i, 5) = dbRecord(3) ' E列: 产品编码 (成品物料码)
' F列 (部件优先) 保持原样，不作修改
matchCount = matchCount + 1 matchCount = matchCount + 1
End If 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 Set dbDict = Nothing
Dim elapsedTime As Double Dim elapsedTime As Double
elapsedTime = Timer - startTime elapsedTime = Timer - startTime
MsgBox "数据提取完成!" & vbCrLf & _ MsgBox "数据提取完成!" & vbCrLf & _
"成功匹配并更新了 " & matchCount & " 条记录。" & vbCrLf & _ "成功匹配并更新了 " & matchCount & " 条筛选记录。" & vbCrLf & _
"用时: " & Format(elapsedTime, "0.00") & " 秒", vbInformation "用时: " & Format(elapsedTime, "0.00") & " 秒", vbInformation
Exit Sub Exit Sub
ErrorHandler: ErrorHandler:
' 确保发生错误时关闭数据库连接 Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
On Error Resume Next On Error Resume Next
If Not rs Is Nothing Then If Not rs Is Nothing Then If rs.State = 1 Then rs.Close
If rs.State = 1 Then rs.Close If Not cn Is Nothing Then If cn.State = 1 Then cn.Close
End If
If Not cn Is Nothing Then
If cn.State = 1 Then cn.Close
End If
On Error GoTo 0 On Error GoTo 0
MsgBox "提取Access数据时发生异常: " & Err.Description, vbCritical MsgBox "提取Access数据时发生异常: " & Err.Description, vbCritical
End Sub End Sub

64
VBA/Modules/BIPUploadModule.bas
View File

@@ -1,6 +1,7 @@
'===================================================================== '=====================================================================
' 模块名: BIPUploadModule ' 模块名: BIPUploadModule
' 功能: 处理产品订单数据，提取BOM后生成[BIP上传模板]格式数据 ' 功能: 处理产品订单数据，提取BOM后生成[BIP上传模板]格式数据
' 特性: [已重构] 支持仅对筛选后的数据进行处理，采用内存极速读取
'===================================================================== '=====================================================================
Option Explicit Option Explicit
@@ -22,6 +23,8 @@ Public Sub ProcessOrdersToBIP()
Dim startTime As Double Dim startTime As Double
startTime = Timer startTime = Timer
Application.ScreenUpdating = False
' 准备工作表对象 ' 准备工作表对象
Dim orderSheet As Worksheet Dim orderSheet As Worksheet
Dim bipSheet As Worksheet Dim bipSheet As Worksheet
@@ -30,6 +33,7 @@ Public Sub ProcessOrdersToBIP()
' 获取[产品订单]工作表 ' 获取[产品订单]工作表
Set orderSheet = GetOrderSheet() Set orderSheet = GetOrderSheet()
If orderSheet Is Nothing Then If orderSheet Is Nothing Then
Application.ScreenUpdating = True
MsgBox "未找到[产品订单]工作表!", vbCritical MsgBox "未找到[产品订单]工作表!", vbCritical
Exit Sub Exit Sub
End If End If
@@ -40,6 +44,7 @@ Public Sub ProcessOrdersToBIP()
' 获取BOM库工作表 ' 获取BOM库工作表
Set bomSheet = GetBomSheet() Set bomSheet = GetBomSheet()
If bomSheet Is Nothing Then If bomSheet Is Nothing Then
Application.ScreenUpdating = True
MsgBox "未找到[平台配置清单]工作表!", vbCritical MsgBox "未找到[平台配置清单]工作表!", vbCritical
Exit Sub Exit Sub
End If End If
@@ -50,6 +55,7 @@ Public Sub ProcessOrdersToBIP()
BomExtractor.SetWorksheet bomSheet BomExtractor.SetWorksheet bomSheet
If Not BomExtractor.LoadBomData Then If Not BomExtractor.LoadBomData Then
Application.ScreenUpdating = True
MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical
Exit Sub Exit Sub
End If End If
@@ -66,22 +72,44 @@ Public Sub ProcessOrdersToBIP()
' 如果只有表头或没有数据 ' 如果只有表头或没有数据
If lastRow < 2 Then If lastRow < 2 Then
Application.ScreenUpdating = True
MsgBox "[产品订单]工作表中没有数据!", vbExclamation MsgBox "[产品订单]工作表中没有数据!", vbExclamation
Exit Sub Exit Sub
End If 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 Dim outputData As Collection
Set outputData = New Collection Set outputData = New Collection
Dim i As Long Dim cell As Range
Dim arrIndex As Long
Dim processedCount As Long Dim processedCount As Long
Dim orderCount As Long Dim orderCount As Long
processedCount = 0 processedCount = 0
orderCount = 0 orderCount = 0
For i = 2 To lastRow ' 遍历筛选出来的可见单元格
For Each cell In visibleRange
' 计算内存数组索引
arrIndex = cell.row - 1
' 读取订单数据 ' 读取订单数据
Dim totalQueueNum As String Dim totalQueueNum As String
Dim orderNumber As String Dim orderNumber As String
@@ -90,13 +118,12 @@ Public Sub ProcessOrdersToBIP()
Dim productCode As String Dim productCode As String
Dim componentPriority As String Dim componentPriority As String
' --- 核心修改：调整列索引以适应新增的A列“总排号” --- totalQueueNum = Trim(sourceDataArr(arrIndex, 1)) ' A列：总排号
totalQueueNum = Trim(orderSheet.Cells(i, 1).value) ' A列：总排号 (如果后续BIP需要可直接使用此变量) orderNumber = Trim(sourceDataArr(arrIndex, 2)) ' B列：生产订单号
orderNumber = Trim(orderSheet.Cells(i, 2).value) ' B列：生产订单号 ProductModel = Trim(sourceDataArr(arrIndex, 3)) ' C列：产品型号
ProductModel = Trim(orderSheet.Cells(i, 3).value) ' C列：产品型号 Quantity = Trim(sourceDataArr(arrIndex, 4)) ' D列：数量
Quantity = Trim(orderSheet.Cells(i, 4).value) ' D列：数量 productCode = Trim(sourceDataArr(arrIndex, 5)) ' E列：产品编码
productCode = Trim(orderSheet.Cells(i, 5).value) ' E列：产品编码 componentPriority = Trim(sourceDataArr(arrIndex, 6)) ' F列：部件优先
componentPriority = Trim(orderSheet.Cells(i, 6).value) ' F列：部件优先
' 跳过空行 ' 跳过空行
If orderNumber = "" And ProductModel = "" Then If orderNumber = "" And ProductModel = "" Then
@@ -105,17 +132,17 @@ Public Sub ProcessOrdersToBIP()
' 验证必填字段 ' 验证必填字段
If orderNumber = "" Then If orderNumber = "" Then
MsgBox "第" & i & "行：生产订单号为空，跳过该行!", vbExclamation MsgBox "工作表第" & cell.row & "行：生产订单号为空，跳过该行!", vbExclamation
GoTo ContinueLoop GoTo ContinueLoop
End If End If
If ProductModel = "" Then If ProductModel = "" Then
MsgBox "第" & i & "行：产品型号为空，跳过该行!", vbExclamation MsgBox "工作表第" & cell.row & "行：产品型号为空，跳过该行!", vbExclamation
GoTo ContinueLoop GoTo ContinueLoop
End If End If
If Quantity = "" Then If Quantity = "" Then
MsgBox "第" & i & "行：数量为空，跳过该行!", vbExclamation MsgBox "工作表第" & cell.row & "行：数量为空，跳过该行!", vbExclamation
GoTo ContinueLoop GoTo ContinueLoop
End If End If
@@ -123,11 +150,11 @@ Public Sub ProcessOrdersToBIP()
' 处理单个订单，收集输出数据 ' 处理单个订单，收集输出数据
ProcessSingleOrder orderNumber, ProductModel, Quantity, productCode, _ ProcessSingleOrder orderNumber, ProductModel, Quantity, productCode, _
componentPriority, BomExtractor, outputData componentPriority, BomExtractor, outputData
processedCount = processedCount + 1 processedCount = processedCount + 1
ContinueLoop: ContinueLoop:
Next i Next cell
' 批量写入数据到工作表 ' 批量写入数据到工作表
If outputData.count > 0 Then If outputData.count > 0 Then
@@ -140,8 +167,10 @@ ContinueLoop:
Dim elapsedTime As Double Dim elapsedTime As Double
elapsedTime = Timer - startTime elapsedTime = Timer - startTime
Application.ScreenUpdating = True
MsgBox "处理完成!" & vbCrLf & _ MsgBox "处理完成!" & vbCrLf & _
"处理订单数: " & orderCount & vbCrLf & _ "处理筛选订单数: " & orderCount & vbCrLf & _
"生成BIP行数: " & outputData.count & vbCrLf & _ "生成BIP行数: " & outputData.count & vbCrLf & _
"用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation
@@ -151,6 +180,7 @@ ContinueLoop:
Exit Sub Exit Sub
ErrorHandler: ErrorHandler:
Application.ScreenUpdating = True
MsgBox "处理异常: " & Err.Description, vbCritical MsgBox "处理异常: " & Err.Description, vbCritical
End Sub End Sub
@@ -284,7 +314,7 @@ Private Function CreateBIPRowArray(orderNumber As String, _
rowData(5) = materialCode ' 材料编码（66 编码） rowData(5) = materialCode ' 材料编码（66 编码）
rowData(6) = "一般发料" ' 供应方式（固定值） rowData(6) = "一般发料" ' 供应方式（固定值）
rowData(7) = Date ' 需用日期（当天日期） rowData(7) = Date ' 需用日期（当天日期）
rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值） rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值）
rowData(9) = Quantity ' 计划出库数量（与生产数量一致） rowData(9) = Quantity ' 计划出库数量（与生产数量一致）
rowData(10) = note ' 备注 rowData(10) = note ' 备注

88
VBA/Modules/ComponentInventoryCheckModule.bas
View File

@@ -1,7 +1,7 @@
'===================================================================== '=====================================================================
' 模块名: ComponentInventoryCheckModule ' 模块名: ComponentInventoryCheckModule
' 功能: 部件库存核对模块 - 自动核对产品订单中"部件"类物料的库存情况 ' 功能: 部件库存核推模块 - 自动核对产品订单中"部件"类物料的库存情况
' 说明: 当库存不足时,按订单顺序将超出部分的订单的"部件优先"字段标记为"否" ' 特性: [已重构] 支持仅对筛选后的数据进行处理，采用内存极速读取
'===================================================================== '=====================================================================
Option Explicit Option Explicit
@@ -43,6 +43,10 @@ Public Sub CheckComponentInventory()
Dim startTime As Double Dim startTime As Double
startTime = Timer startTime = Timer
' 提升性能：关闭屏幕更新和自动计算
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' 获取工作表对象 ' 获取工作表对象
Dim orderSheet As Worksheet Dim orderSheet As Worksheet
Dim inventorySheet As Worksheet Dim inventorySheet As Worksheet
@@ -50,18 +54,21 @@ Public Sub CheckComponentInventory()
Set orderSheet = GetOrderSheet() Set orderSheet = GetOrderSheet()
If orderSheet Is Nothing Then If orderSheet Is Nothing Then
RestoreAppStatus
MsgBox "未找到[产品订单]工作表!", vbExclamation MsgBox "未找到[产品订单]工作表!", vbExclamation
Exit Sub Exit Sub
End If End If
Set inventorySheet = GetInventorySheet() Set inventorySheet = GetInventorySheet()
If inventorySheet Is Nothing Then If inventorySheet Is Nothing Then
RestoreAppStatus
MsgBox "未找到[现存量]工作表!", vbExclamation MsgBox "未找到[现存量]工作表!", vbExclamation
Exit Sub Exit Sub
End If End If
Set bomSheet = GetBomSheet() Set bomSheet = GetBomSheet()
If bomSheet Is Nothing Then If bomSheet Is Nothing Then
RestoreAppStatus
MsgBox "未找到[平台配置清单]工作表!", vbExclamation MsgBox "未找到[平台配置清单]工作表!", vbExclamation
Exit Sub Exit Sub
End If End If
@@ -70,16 +77,30 @@ Public Sub CheckComponentInventory()
Dim lastRow As Long Dim lastRow As Long
lastRow = orderSheet.Cells(orderSheet.Rows.count, 3).End(xlUp).row lastRow = orderSheet.Cells(orderSheet.Rows.count, 3).End(xlUp).row
If lastRow < 2 Then If lastRow < 2 Then
RestoreAppStatus
MsgBox "[产品订单]工作表没有数据!", vbExclamation MsgBox "[产品订单]工作表没有数据!", vbExclamation
Exit Sub Exit Sub
End If 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提取器 ' 初始化BOM提取器
Dim BomExtractor As BomExtractor Dim BomExtractor As BomExtractor
Set BomExtractor = New BomExtractor Set BomExtractor = New BomExtractor
BomExtractor.SetWorksheet bomSheet BomExtractor.SetWorksheet bomSheet
If Not BomExtractor.LoadBomData Then If Not BomExtractor.LoadBomData Then
RestoreAppStatus
MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical
Exit Sub Exit Sub
End If End If
@@ -89,16 +110,18 @@ Public Sub CheckComponentInventory()
Set inventoryData = LoadInventoryData(inventorySheet) Set inventoryData = LoadInventoryData(inventorySheet)
If inventoryData.count = 0 Then If inventoryData.count = 0 Then
RestoreAppStatus
MsgBox "[现存量]工作表没有有效数据!", vbExclamation MsgBox "[现存量]工作表没有有效数据!", vbExclamation
Exit Sub Exit Sub
End If End If
' 读取订单数据 ' 【核心重构】传递可见区域和总行数，仅读取可见订单数据
Dim orders As Collection Dim orders As Collection
Set orders = LoadOrderData(orderSheet) Set orders = LoadOrderData(orderSheet, visibleRange, lastRow)
If orders.count = 0 Then If orders.count = 0 Then
MsgBox "没有有效的订单数据!", vbExclamation RestoreAppStatus
MsgBox "可见区域中没有有效的订单数据!", vbExclamation
Exit Sub Exit Sub
End If End If
@@ -110,7 +133,8 @@ Public Sub CheckComponentInventory()
Set componentDemands = CalculateComponentDemand(orders) Set componentDemands = CalculateComponentDemand(orders)
If componentDemands.count = 0 Then If componentDemands.count = 0 Then
MsgBox "没有订单包含'部件'类别物料,无需处理库存!", vbInformation RestoreAppStatus
MsgBox "筛选的订单中没有包含'部件'类别物料,无需处理库存!", vbInformation
Exit Sub Exit Sub
End If End If
@@ -118,17 +142,20 @@ Public Sub CheckComponentInventory()
Dim validationWarnings As Collection Dim validationWarnings As Collection
Set validationWarnings = ValidateInventory(componentDemands, inventoryData) Set validationWarnings = ValidateInventory(componentDemands, inventoryData)
' 按订单顺序分配库存 ' 按订单顺序分配库存并标记
Dim stats As Statistics Dim stats As Statistics
AllocateInventory orders, componentDemands, orderSheet, stats AllocateInventory orders, componentDemands, orderSheet, stats
' 恢复应用状态
RestoreAppStatus
' 输出结果统计 ' 输出结果统计
Dim elapsedTime As Double Dim elapsedTime As Double
elapsedTime = Timer - startTime elapsedTime = Timer - startTime
Dim resultMsg As String Dim resultMsg As String
resultMsg = "部件库存核对完成!" & vbCrLf & vbCrLf resultMsg = "部件库存核对完成!" & vbCrLf & vbCrLf
resultMsg = resultMsg & "处理订单数: " & stats.TotalOrders & vbCrLf resultMsg = resultMsg & "处理筛选订单数: " & stats.TotalOrders & vbCrLf
resultMsg = resultMsg & "包含部件订单: " & stats.OrdersWithComponent & vbCrLf resultMsg = resultMsg & "包含部件订单: " & stats.OrdersWithComponent & vbCrLf
resultMsg = resultMsg & "库存充足订单: " & stats.OrdersSufficient & vbCrLf resultMsg = resultMsg & "库存充足订单: " & stats.OrdersSufficient & vbCrLf
resultMsg = resultMsg & "库存不足订单: " & stats.OrdersInsufficient & vbCrLf resultMsg = resultMsg & "库存不足订单: " & stats.OrdersInsufficient & vbCrLf
@@ -148,37 +175,54 @@ Public Sub CheckComponentInventory()
Exit Sub Exit Sub
ErrorHandler: ErrorHandler:
RestoreAppStatus
MsgBox "部件库存核对异常: " & Err.Description, vbCritical MsgBox "部件库存核对异常: " & Err.Description, vbCritical
End Sub End Sub
'=====================================================================
' 辅助过程: RestoreAppStatus
' 功能: 恢复Excel应用程序的状态
'=====================================================================
Private Sub RestoreAppStatus()
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
'===================================================================== '=====================================================================
' 函数: LoadOrderData ' 函数: LoadOrderData
' 功能: 读取订单数据 ' 功能: 读取订单数据
' 参数: ws - [产品订单]工作表 ' 参数: ws - [产品订单]工作表
' 返回: Collection - 每个元素是字典对象,包含订单信息 ' 返回: 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 Set LoadOrderData = New Collection
' 调整为按C列获取最后一行 ' 全量读入内存数组提升速度
Dim lastRow As Long Dim sourceDataArr As Variant
lastRow = ws.Cells(ws.Rows.count, 3).End(xlUp).row sourceDataArr = ws.Range("A2:F" & lastRow).value
Dim i As Long Dim cell As Range
For i = 2 To lastRow Dim arrIndex As Long
' 仅遍历可见的单元格
For Each cell In visibleRange
Dim model As String Dim model As String
Dim qty As Variant Dim qty As Variant
' --- 核心修改：列索引向右移1列 --- ' 数组索引 = Excel行号 - 1
model = Trim(ws.Cells(i, 3).value) ' C列: 产品型号 (原B列) arrIndex = cell.row - 1
qty = ws.Cells(i, 4).value ' D列: 产品数量 (原C列)
' 从内存数组中提取数据
model = Trim(sourceDataArr(arrIndex, 3)) ' C列: 产品型号
qty = sourceDataArr(arrIndex, 4) ' D列: 产品数量
' 跳过空行 ' 跳过空行
If model <> "" Then If model <> "" Then
Dim order As Object Dim order As Object
Set order = CreateObject("Scripting.Dictionary") 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_MODEL, CStr(model)
order.Add ORDER_QUANTITY, CDbl(IIf(IsNull(qty) Or IsEmpty(qty), 0, qty)) order.Add ORDER_QUANTITY, CDbl(IIf(IsNull(qty) Or IsEmpty(qty), 0, qty))
order.Add ORDER_COMP_CODE, "" order.Add ORDER_COMP_CODE, ""
@@ -188,7 +232,7 @@ Private Function LoadOrderData(ws As Worksheet) As Collection
LoadOrderData.Add order LoadOrderData.Add order
End If End If
Next i Next cell
End Function End Function
'===================================================================== '=====================================================================
@@ -327,15 +371,12 @@ Private Function ValidateInventory(componentDemands As Object, _
' 检查库存中是否存在该部件 ' 检查库存中是否存在该部件
If Not inventoryData.Exists(compInv(INV_CODE)) Then If Not inventoryData.Exists(compInv(INV_CODE)) Then
' 库存中找不到，设置库存为0，并添加警告
compInv(INV_STOCK) = 0 compInv(INV_STOCK) = 0
compInv(INV_SHORTAGE) = True compInv(INV_SHORTAGE) = True
ValidateInventory.Add "部件 '" & compInv(INV_CODE) & "' 在[现存量]中未找到" ValidateInventory.Add "部件 '" & compInv(INV_CODE) & "' 在[现存量]中未找到"
Else Else
' 设置可用库存
compInv(INV_STOCK) = inventoryData(compInv(INV_CODE)) compInv(INV_STOCK) = inventoryData(compInv(INV_CODE))
' 检查是否短缺
If compInv(INV_DEMAND) > compInv(INV_STOCK) Then If compInv(INV_DEMAND) > compInv(INV_STOCK) Then
compInv(INV_SHORTAGE) = True compInv(INV_SHORTAGE) = True
End If End If
@@ -402,8 +443,7 @@ Private Sub AllocateInventory(orders As Collection, _
compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty
stats.OrdersSufficient = stats.OrdersSufficient + 1 stats.OrdersSufficient = stats.OrdersSufficient + 1
Else Else
' --- 核心修改：回填结果写入F列(第6列) --- ' --- 因为已经保存了真正的行号 ORDER_ROW, 在关闭屏幕刷新的情况下，这里直接写入是非常快的 ---
' 库存不足,标记为"否"
orderSheet.Cells(order(ORDER_ROW), 6).value = "否" orderSheet.Cells(order(ORDER_ROW), 6).value = "否"
compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty
stats.OrdersInsufficient = stats.OrdersInsufficient + 1 stats.OrdersInsufficient = stats.OrdersInsufficient + 1

72
VBA/Modules/MainModule.bas
View File

@@ -1,6 +1,7 @@
'===================================================================== '=====================================================================
' 模块名: MainModule ' 模块名: MainModule
' 功能: 主控模块,处理产品型号提取和BOM匹配的上层逻辑 ' 功能: 主控模块,处理产品型号提取和BOM匹配的上层逻辑
' 特性: [已重构] 支持仅对筛选后的数据进行处理，采用内存极速读取
'===================================================================== '=====================================================================
Option Explicit Option Explicit
@@ -22,6 +23,9 @@ Public Sub ProcessProductModels()
Dim startTime As Double Dim startTime As Double
startTime = Timer startTime = Timer
' 关闭屏幕刷新提升速度
Application.ScreenUpdating = False
' 准备输入输出 ' 准备输入输出
Dim inputSheet As Worksheet Dim inputSheet As Worksheet
Dim outputSheet As Worksheet Dim outputSheet As Worksheet
@@ -30,6 +34,7 @@ Public Sub ProcessProductModels()
' 获取工作表 ' 获取工作表
Set inputSheet = GetInputSheet() Set inputSheet = GetInputSheet()
If inputSheet Is Nothing Then If inputSheet Is Nothing Then
Application.ScreenUpdating = True
MsgBox "未找到输入工作表,请确保工作簿中有包含订单数据的工作表", vbCritical MsgBox "未找到输入工作表,请确保工作簿中有包含订单数据的工作表", vbCritical
Exit Sub Exit Sub
End If End If
@@ -37,6 +42,7 @@ Public Sub ProcessProductModels()
' 获取BOM库工作表 ' 获取BOM库工作表
Set bomSheet = GetBomSheet() Set bomSheet = GetBomSheet()
If bomSheet Is Nothing Then If bomSheet Is Nothing Then
Application.ScreenUpdating = True
MsgBox "未找到'平台配置清单'工作表,请确保BOM数据存在", vbCritical MsgBox "未找到'平台配置清单'工作表,请确保BOM数据存在", vbCritical
Exit Sub Exit Sub
End If End If
@@ -50,14 +56,36 @@ Public Sub ProcessProductModels()
BomExtractor.SetWorksheet bomSheet BomExtractor.SetWorksheet bomSheet
If Not BomExtractor.LoadBomData Then If Not BomExtractor.LoadBomData Then
Application.ScreenUpdating = True
MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical
Exit Sub Exit Sub
End If End If
' 处理每个产品型号
Dim lastRow As Long Dim lastRow As Long
lastRow = inputSheet.Cells(inputSheet.Rows.count, 1).End(xlUp).row 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 WriteOutputHeader outputSheet
@@ -65,30 +93,34 @@ Public Sub ProcessProductModels()
Dim outputData As Collection Dim outputData As Collection
Set outputData = New Collection Set outputData = New Collection
Dim i As Long Dim cell As Range
Dim arrIndex As Long
Dim modelString As String Dim modelString As String
Dim processedCount As Long Dim processedCount As Long
processedCount = 0 processedCount = 0
' 假设数据从第2行开始 ' 仅遍历筛选出来的可见行
For i = 2 To lastRow For Each cell In visibleRange
Dim totalQueueNum As String Dim totalQueueNum As String
Dim orderNumber As String Dim orderNumber As String
Dim componentPriority As String Dim componentPriority As String
' --- 核心修改：调整列索引以适应新增的“总排号” --- ' 将工作表行号映射到数组索引
totalQueueNum = Trim(inputSheet.Cells(i, 1).value) ' A列：总排号 arrIndex = cell.row - 1
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列右移一列) 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 If modelString <> "" Then
' 处理单个型号，收集数据，增加 totalQueueNum 参数 ' 处理单个型号，收集数据
ProcessSingleModel totalQueueNum, orderNumber, modelString, componentPriority, BomExtractor, outputData ProcessSingleModel totalQueueNum, orderNumber, modelString, componentPriority, BomExtractor, outputData
processedCount = processedCount + 1 processedCount = processedCount + 1
End If End If
Next i Next cell
' 批量写入数据到工作表 ' 批量写入数据到工作表
If outputData.count > 0 Then If outputData.count > 0 Then
@@ -101,8 +133,10 @@ Public Sub ProcessProductModels()
Dim elapsedTime As Double Dim elapsedTime As Double
elapsedTime = Timer - startTime elapsedTime = Timer - startTime
Application.ScreenUpdating = True
MsgBox "处理完成!" & vbCrLf & _ MsgBox "处理完成!" & vbCrLf & _
"处理型号数: " & processedCount & vbCrLf & _ "处理筛选型号数: " & processedCount & vbCrLf & _
"用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation
' 激活输出表 ' 激活输出表
@@ -111,6 +145,7 @@ Public Sub ProcessProductModels()
Exit Sub Exit Sub
ErrorHandler: ErrorHandler:
Application.ScreenUpdating = True
MsgBox "处理异常: " & Err.Description, vbCritical MsgBox "处理异常: " & Err.Description, vbCritical
End Sub End Sub
@@ -227,7 +262,7 @@ Private Sub WriteOutputHeader(ws As Worksheet)
' BOM字段表头 ' 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 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 Dim labels() As String
GetConditionConfig condNames, labels GetConditionConfig condNames, labels
' 计算总列数：3 (排号+订单+型号) + 条件数 + 8 (BOM+备注) ' 计算总列数：3 (排号+订单+型号) + 条件数 + 7 (BOM字段减去代号后剩6个 + 1个备注)
Dim totalCols As Long 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 ReDim rowData(1 To totalCols) As Variant
@@ -286,14 +321,14 @@ Private Function CreateOutputRowArray(totalQueueNum As String, _
If Not item Is Nothing Then If Not item Is Nothing Then
rowData(col) = item.RowNumber: col = col + 1 rowData(col) = item.RowNumber: col = col + 1
rowData(col) = item.Module: 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.Name: col = col + 1
rowData(col) = item.Quantity: col = col + 1 rowData(col) = item.Quantity: col = col + 1
rowData(col) = item.category: col = col + 1 rowData(col) = item.category: col = col + 1
rowData(col) = item.Code66: col = col + 1 rowData(col) = item.Code66: col = col + 1
Else Else
' 跳过BOM字段 ' 跳过BOM字段 (原本是7个字段，去掉代号后变成6个字段)
col = col + 7 col = col + 6
End If End If
' 备注 ' 备注
@@ -301,6 +336,7 @@ Private Function CreateOutputRowArray(totalQueueNum As String, _
CreateOutputRowArray = rowData CreateOutputRowArray = rowData
End Function End Function
'===================================================================== '=====================================================================
' 过程: WriteBatchData ' 过程: WriteBatchData
' 功能: 批量写入数据到工作表 ' 功能: 批量写入数据到工作表