36c00befa5
- 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>
470 lines
16 KiB
QBasic
470 lines
16 KiB
QBasic
'=====================================================================
|
||
' 模块名: 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: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 cell As Range
|
||
Dim arrIndex As Long
|
||
Dim processedCount As Long
|
||
Dim orderCount As Long
|
||
|
||
processedCount = 0
|
||
orderCount = 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
|
||
|
||
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
|
||
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 & _
|
||
"生成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
|
||
|
||
Dim extractNote As String
|
||
extractNote = ""
|
||
|
||
If Not parser.Parse(ProductModel) Then
|
||
' 解析失败，添加一行错误记录
|
||
extractNote = "解析失败: " & parser.ErrorMessage
|
||
outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, 1, "", extractNote)
|
||
Exit Sub
|
||
End If
|
||
|
||
' 提取BOM
|
||
Dim matchedItems As Collection
|
||
Set matchedItems = BomExtractor.ExtractBom(parser.Conditions)
|
||
|
||
' 获取错误信息
|
||
Dim bomErrors As String
|
||
bomErrors = BomExtractor.GetErrorSummary
|
||
If bomErrors <> "" Then
|
||
extractNote = bomErrors
|
||
End If
|
||
|
||
' 输出结果
|
||
If matchedItems.count = 0 Then
|
||
' 没有匹配项，添加一行空记录
|
||
If extractNote = "" Then
|
||
extractNote = "未匹配到任何物料"
|
||
End If
|
||
outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, 1, "", extractNote)
|
||
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
|
||
Dim itemNote As String
|
||
itemNote = extractNote
|
||
|
||
' 添加物料特定的错误
|
||
If item.MatchError <> "" Then
|
||
If itemNote <> "" Then itemNote = itemNote & "; "
|
||
itemNote = itemNote & item.MatchError
|
||
End If
|
||
|
||
' 计算实际行号：行号 = 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, itemNote)
|
||
|
||
lineIndex = lineIndex + 1
|
||
Next item
|
||
End If
|
||
End Sub
|
||
|
||
'=====================================================================
|
||
' 函数：CreateBIPRowArray
|
||
' 功能：创建 BIP 上传模板一行数据的数组
|
||
' 参数：orderNumber - 生产订单号
|
||
' productCode - 产品编码
|
||
' quantity - 生产数量
|
||
' actualRowNumber - 实际行号（BIP 行号基数 + 组内序号）
|
||
' materialCode - 材料编码（66 编码）
|
||
' note - 备注
|
||
' 返回：Variant() - 包含 10 个元素的数组
|
||
'=====================================================================
|
||
Private Function CreateBIPRowArray(orderNumber As String, _
|
||
productCode As String, _
|
||
Quantity As String, _
|
||
actualRowNumber 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) = actualRowNumber ' 行号
|
||
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上传模板表头
|
||
' 参数: 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 = "计划出库数量"
|
||
ws.Cells(1, 10).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 |