From 1747af046bf9506fdcb256eeb865fbb24306fa10 Mon Sep 17 00:00:00 2001 From: Misaka_Company Date: Thu, 12 Mar 2026 13:53:28 +0800 Subject: [PATCH] feat: add Access data integration and total queue number column MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Add new AccessDataModule for fetching data from Access database based on total queue number - Add CommandButton3_Click handler in Sheet9 for Access data fetch - Add support for new "总排号" (Total Queue Number) column at column A - Adjust all column indices to accommodate the new column (shifted by +1) - Standardize code style: Collection, Count, Quantity, ProductModel, Description - Fix inventory check result to write to correct column (F instead of E) Co-Authored-By: Claude Sonnet 4.6 --- VBA/ClassModules/BomExtractor.cls | 64 +++---- VBA/ClassModules/BomItem.cls | 4 +- VBA/ClassModules/ProductModelParser.cls | 6 +- VBA/DocumentModules/Sheet9.cls | 8 + VBA/Modules/AccessDataModule.bas | 174 ++++++++++++++++++ VBA/Modules/BIPUploadModule.bas | 81 ++++---- VBA/Modules/ComponentInventoryCheckModule.bas | 63 ++++--- VBA/Modules/MainModule.bas | 82 +++++---- VBA/Modules/TestModule.bas | 6 +- 9 files changed, 343 insertions(+), 145 deletions(-) create mode 100644 VBA/Modules/AccessDataModule.bas diff --git a/VBA/ClassModules/BomExtractor.cls b/VBA/ClassModules/BomExtractor.cls index 72bddea..f5ea0bf 100644 --- a/VBA/ClassModules/BomExtractor.cls +++ b/VBA/ClassModules/BomExtractor.cls @@ -7,12 +7,12 @@ Option Explicit Private pWorksheet As Worksheet Private pConditionEvaluator As ConditionEvaluator -Private pAllItems As collection ' 所有BOM项 -Private pMatchedItems As collection ' 匹配的BOM项 -Private pRequiredCategories As collection ' 需要的类别 +Private pAllItems As Collection ' 所有BOM项 +Private pMatchedItems As Collection ' 匹配的BOM项 +Private pRequiredCategories As Collection ' 需要的类别 Private pCategoryHierarchy As Object ' 类别层次结构 Dictionary(子类别->父类别) -Private pErrorMessages As collection -Private pExcludeCategories As collection ' 需要排除的类别 +Private pErrorMessages As Collection +Private pExcludeCategories As Collection ' 需要排除的类别 '===================================================================== ' 方法: Class_Initialize @@ -20,12 +20,12 @@ Private pExcludeCategories As collection ' 需要排除的类别 '===================================================================== Private Sub Class_Initialize() Set pConditionEvaluator = New ConditionEvaluator - Set pAllItems = New collection - Set pMatchedItems = New collection - Set pRequiredCategories = New collection + Set pAllItems = New Collection + Set pMatchedItems = New Collection + Set pRequiredCategories = New Collection Set pCategoryHierarchy = CreateObject("Scripting.Dictionary") - Set pErrorMessages = New collection - Set pExcludeCategories = New collection + Set pErrorMessages = New Collection + Set pExcludeCategories = New Collection End Sub '===================================================================== @@ -52,12 +52,12 @@ Public Function LoadBomData() As Boolean End If ' 清空现有数据 - Set pAllItems = New collection + Set pAllItems = New Collection Set pCategoryHierarchy = CreateObject("Scripting.Dictionary") ' 从第4行开始读取(第3行是表头) Dim lastRow As Long - lastRow = pWorksheet.Cells(pWorksheet.Rows.Count, 1).End(xlUp).row + lastRow = pWorksheet.Cells(pWorksheet.Rows.count, 1).End(xlUp).row Dim i As Long Dim item As BomItem @@ -89,7 +89,7 @@ Public Function LoadBomData() As Boolean Exit Function ErrorHandler: - pErrorMessages.Add "加载BOM数据异常: " & Err.description + pErrorMessages.Add "加载BOM数据异常: " & Err.Description LoadBomData = False End Function @@ -98,7 +98,7 @@ End Function ' 功能: 设置需要排除的类别 ' 参数: categories - 类别集合 '===================================================================== -Public Sub SetExcludeCategories(categories As collection) +Public Sub SetExcludeCategories(categories As Collection) Set pExcludeCategories = categories End Sub @@ -107,7 +107,7 @@ End Sub ' 功能: 清空排除类别列表 '===================================================================== Public Sub ClearExcludeCategories() - Set pExcludeCategories = New collection + Set pExcludeCategories = New Collection End Sub '===================================================================== @@ -115,7 +115,7 @@ End Sub ' 功能: 清空错误信息列表 '===================================================================== Public Sub ClearErrorMessages() - Set pErrorMessages = New collection + Set pErrorMessages = New Collection End Sub '===================================================================== @@ -124,13 +124,13 @@ End Sub ' 参数: productConditions - 产品条件字典 ' 返回: Collection - 匹配的BOM项集合 '===================================================================== -Public Function ExtractBom(productConditions As Object) As collection +Public Function ExtractBom(productConditions As Object) As Collection On Error GoTo ErrorHandler ' 清空结果 - Set pMatchedItems = New collection - Set pRequiredCategories = New collection - Set pErrorMessages = New collection + Set pMatchedItems = New Collection + Set pRequiredCategories = New Collection + Set pErrorMessages = New Collection ' 第一步:确定需要的类别 DetermineRequiredCategories productConditions @@ -148,7 +148,7 @@ Public Function ExtractBom(productConditions As Object) As collection Exit Function ErrorHandler: - pErrorMessages.Add "提取BOM异常: " & Err.description + pErrorMessages.Add "提取BOM异常: " & Err.Description Set ExtractBom = pMatchedItems End Function @@ -211,8 +211,8 @@ Private Sub MatchItems(productConditions As Object) ' 遍历每个需要的类别 For Each category In pRequiredCategories - Dim categoryMatches As collection - Set categoryMatches = New collection + Dim categoryMatches As Collection + Set categoryMatches = New Collection ' 查找该类别下所有匹配的物料 For Each item In pAllItems @@ -235,19 +235,19 @@ Private Sub MatchItems(productConditions As Object) Next item ' 检查匹配结果 - If categoryMatches.Count = 0 Then + If categoryMatches.count = 0 Then ' --------------------------------------------------------- ' CHANGE: 这里不再立即报错 ' 理由: 未匹配到可能是正常的（例如：父类别缺失但子类别齐全，或者子类别被父类别覆盖） ' 具体的缺失检查移交到 ValidateResult 方法中统一处理 ' --------------------------------------------------------- - ElseIf categoryMatches.Count = 1 Then + ElseIf categoryMatches.count = 1 Then ' 正常:匹配到1条 pMatchedItems.Add categoryMatches(1) Else ' 异常:匹配到多条 (这个依然需要报错，因为这是数据源的不确定性错误) Dim multiMsg As String - multiMsg = "类别[" & category & "]匹配到多条物料(" & categoryMatches.Count & "条)" + multiMsg = "类别[" & category & "]匹配到多条物料(" & categoryMatches.count & "条)" pErrorMessages.Add multiMsg ' 临时处理:输出所有匹配的 @@ -303,8 +303,8 @@ Private Sub ApplyAssemblyLogic() Dim coveredCategories As Object Set coveredCategories = CreateObject("Scripting.Dictionary") - Dim satisfiedParentItems As collection - Set satisfiedParentItems = New collection + Dim satisfiedParentItems As Collection + Set satisfiedParentItems = New Collection For Each parentCat In parentToChildren.Keys ' 只有当该父类别确实有匹配物料时才进行检查 @@ -345,8 +345,8 @@ Private Sub ApplyAssemblyLogic() Next parentCat ' 4. 构建新的结果集 - Dim newMatchedItems As collection - Set newMatchedItems = New collection + Dim newMatchedItems As Collection + Set newMatchedItems = New Collection ' 4.1 先添加满足条件的父类别项 (总成) For Each item In satisfiedParentItems @@ -459,7 +459,7 @@ End Sub ' 功能: 获取错误信息集合 ' 返回: Collection '===================================================================== -Public Function GetErrorMessages() As collection +Public Function GetErrorMessages() As Collection Set GetErrorMessages = pErrorMessages End Function @@ -469,7 +469,7 @@ End Function ' 返回: String '===================================================================== Public Function GetErrorSummary() As String - If pErrorMessages.Count = 0 Then + If pErrorMessages.count = 0 Then GetErrorSummary = "" Else Dim result As String diff --git a/VBA/ClassModules/BomItem.cls b/VBA/ClassModules/BomItem.cls index 6b224e7..3c12ef5 100644 --- a/VBA/ClassModules/BomItem.cls +++ b/VBA/ClassModules/BomItem.cls @@ -10,7 +10,7 @@ Public RowNumber As Long ' 行号 Public Module As String ' 模块 Public code As String ' 代号 Public Name As String ' 名称 -Public quantity As Double ' 数量 +Public Quantity As Double ' 数量 Public SelectCondition As String ' 选择条件 Public Remark As String ' 备注 Public category As String ' 类别 @@ -44,7 +44,7 @@ Public Sub LoadFromRow(ws As Worksheet, row As Long) Me.Module = CStr(ws.Cells(row, 2).value) ' B列: 模块 Me.code = CStr(ws.Cells(row, 3).value) ' C列: 代号 Me.Name = CStr(ws.Cells(row, 4).value) ' D列: 名称 - Me.quantity = CDbl(ws.Cells(row, 5).value) ' E列: 数量 + Me.Quantity = CDbl(ws.Cells(row, 5).value) ' E列: 数量 Me.SelectCondition = CStr(ws.Cells(row, 6).value) ' F列: 选择条件 Me.Remark = CStr(ws.Cells(row, 7).value) ' G列: 备注 Me.category = CStr(ws.Cells(row, 8).value) ' H列: 类别 diff --git a/VBA/ClassModules/ProductModelParser.cls b/VBA/ClassModules/ProductModelParser.cls index f9c7594..3d608f2 100644 --- a/VBA/ClassModules/ProductModelParser.cls +++ b/VBA/ClassModules/ProductModelParser.cls @@ -86,7 +86,7 @@ Public Function Parse(modelString As String) As Boolean Exit Function ErrorHandler: - pErrorMessage = "解析异常: " & Err.description + pErrorMessage = "解析异常: " & Err.Description Parse = False End Function @@ -179,7 +179,7 @@ Private Function ParseHeader() As Boolean Exit Function ErrorHandler: - pErrorMessage = "解析表头异常: " & Err.description + pErrorMessage = "解析表头异常: " & Err.Description ParseHeader = False End Function @@ -221,7 +221,7 @@ Private Function ExtractConnectionAndMaterial(code As String, _ Exit Function ErrorHandler: - pErrorMessage = "提取过程连接和材质异常: " & Err.description + pErrorMessage = "提取过程连接和材质异常: " & Err.Description ExtractConnectionAndMaterial = False End Function diff --git a/VBA/DocumentModules/Sheet9.cls b/VBA/DocumentModules/Sheet9.cls index dc24cba..45fbb8b 100644 --- a/VBA/DocumentModules/Sheet9.cls +++ b/VBA/DocumentModules/Sheet9.cls @@ -13,4 +13,12 @@ End Sub '===================================================================== Private Sub CommandButton2_Click() Call CheckComponentInventory +End Sub + +'===================================================================== +' 数据提取按钮点击事件 +' 功能:基于总排号查询相关字段数据 +'===================================================================== +Private Sub CommandButton3_Click() + Call FetchDataFromAccess End Sub \ No newline at end of file diff --git a/VBA/Modules/AccessDataModule.bas b/VBA/Modules/AccessDataModule.bas new file mode 100644 index 0000000..5ed2506 --- /dev/null +++ b/VBA/Modules/AccessDataModule.bas @@ -0,0 +1,174 @@ +'===================================================================== +' 模块名: AccessDataModule +' 功能: 连接Access数据库，根据[总排号]提取数据并填充到[产品订单]工作表 +'===================================================================== + +Option Explicit + +'===================================================================== +' 配置区域 (请根据你的实际情况修改以下常量) +'===================================================================== +' Access数据库文件的完整路径 +Private Const DB_PATH = "\\192.168.110.114\生产进度表\2025年数据\生产合同数据.accdb" +' Access中目标数据表的名称 +Private Const TARGET_TABLE = "26年压力表合同数据" + +'===================================================================== +' 过程: FetchDataFromAccess +' 功能: 主控程序，执行数据提取和回填逻辑 +'===================================================================== +Public Sub FetchDataFromAccess() + On Error GoTo ErrorHandler + + Dim startTime As Double + startTime = Timer + + Dim ws As Worksheet + Set ws = GetOrderSheet() + If ws Is Nothing Then + MsgBox "未找到[产品订单]工作表，请检查工作表名称。", vbCritical + Exit Sub + End If + + Dim lastRow As Long + lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).row + + If lastRow < 2 Then + MsgBox "[产品订单]工作表中没有需要处理的数据。", vbInformation + Exit Sub + End If + + ' 1. 将Excel数据读入内存数组 (A到F列) + Dim dataArr As Variant + dataArr = ws.Range("A2:F" & lastRow).value + + ' 收集所有的总排号，用于构建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 + Exit Sub + End If + + ' 去除最后一个逗号 + queueNums = Left(queueNums, Len(queueNums) - 1) + + ' 2. 连接Access数据库并查询 + Dim cn As Object + Dim 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 + + ' 3. 将查询结果存入字典，利用字典的哈希特性实现极速匹配 + Dim dbDict As Object + Set dbDict = CreateObject("Scripting.Dictionary") + + If Not rs.EOF Then + rs.MoveFirst + 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, _ + rs.Fields("产品型号").value, _ + rs.Fields("数量").value, _ + rs.Fields("成品物料码").value _ + ) + End If + rs.MoveNext + Loop + End If + + ' 关闭数据库连接 + rs.Close + cn.Close + Set rs = Nothing + Set cn = Nothing + + ' 4. 将字典中的数据回填到内存数组 + Dim matchCount As Long + matchCount = 0 + + For i = 1 To UBound(dataArr, 1) + currentNum = Trim(dataArr(i, 1)) + 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列 (部件优先) 保持原样，不作修改 + + matchCount = matchCount + 1 + End If + Next i + + ' 5. 将更新后的数组一次性写回工作表 + ws.Range("A2:F" & lastRow).value = dataArr + + ' 清理内存 + Set dbDict = Nothing + + Dim elapsedTime As Double + elapsedTime = Timer - startTime + + MsgBox "数据提取完成!" & vbCrLf & _ + "成功匹配并更新了 " & matchCount & " 条记录。" & vbCrLf & _ + "用时: " & Format(elapsedTime, "0.00") & " 秒", vbInformation + + Exit Sub + +ErrorHandler: + ' 确保发生错误时关闭数据库连接 + 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 + On Error GoTo 0 + + MsgBox "提取Access数据时发生异常: " & Err.Description, vbCritical +End Sub + +'===================================================================== +' 函数: GetOrderSheet +' 功能: 获取[产品订单]工作表 +' 返回: Worksheet - 工作表对象 +'===================================================================== +Private Function GetOrderSheet() As Worksheet + On Error Resume Next + Set GetOrderSheet = ThisWorkbook.Worksheets("产品订单") + On Error GoTo 0 +End Function \ No newline at end of file diff --git a/VBA/Modules/BIPUploadModule.bas b/VBA/Modules/BIPUploadModule.bas index 302df40..593c42d 100644 --- a/VBA/Modules/BIPUploadModule.bas +++ b/VBA/Modules/BIPUploadModule.bas @@ -64,7 +64,7 @@ Public Sub ProcessOrdersToBIP() ' 获取订单数据行数 Dim lastRow As Long - lastRow = orderSheet.Cells(orderSheet.Rows.Count, 1).End(xlUp).row + lastRow = orderSheet.Cells(orderSheet.Rows.count, 1).End(xlUp).row ' 如果只有表头或没有数据 If lastRow < 2 Then @@ -73,8 +73,8 @@ Public Sub ProcessOrdersToBIP() End If ' 处理每个订单，收集所有输出数据 - Dim outputData As collection - Set outputData = New collection + Dim outputData As Collection + Set outputData = New Collection Dim i As Long Dim processedCount As Long @@ -85,20 +85,23 @@ Public Sub ProcessOrdersToBIP() For i = 2 To lastRow ' 读取订单数据 + Dim totalQueueNum As String Dim orderNumber As String - Dim productModel As String - Dim quantity As String + Dim ProductModel As String + Dim Quantity As String Dim productCode As String Dim componentPriority As String - orderNumber = Trim(orderSheet.Cells(i, 1).value) ' A列：生产订单号 - productModel = Trim(orderSheet.Cells(i, 2).value) ' B列：产品型号 - quantity = Trim(orderSheet.Cells(i, 3).value) ' C列：数量 - productCode = Trim(orderSheet.Cells(i, 4).value) ' D列：产品编码 - componentPriority = Trim(orderSheet.Cells(i, 5).value) ' E列：部件优先 + ' --- 核心修改：调整列索引以适应新增的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列：部件优先 ' 跳过空行 - If orderNumber = "" And productModel = "" Then + If orderNumber = "" And ProductModel = "" Then GoTo ContinueLoop End If @@ -108,12 +111,12 @@ Public Sub ProcessOrdersToBIP() GoTo ContinueLoop End If - If productModel = "" Then + If ProductModel = "" Then MsgBox "第" & i & "行：产品型号为空，跳过该行!", vbExclamation GoTo ContinueLoop End If - If quantity = "" Then + If Quantity = "" Then MsgBox "第" & i & "行：数量为空，跳过该行!", vbExclamation GoTo ContinueLoop End If @@ -121,7 +124,7 @@ Public Sub ProcessOrdersToBIP() orderCount = orderCount + 1 ' 处理单个订单，收集输出数据 - ProcessSingleOrder orderNumber, productModel, quantity, productCode, _ + ProcessSingleOrder orderNumber, ProductModel, Quantity, productCode, _ componentPriority, BomExtractor, outputData processedCount = processedCount + 1 @@ -129,7 +132,7 @@ ContinueLoop: Next i ' 批量写入数据到工作表 - If outputData.Count > 0 Then + If outputData.count > 0 Then WriteBatchData bipSheet, outputData End If @@ -141,7 +144,7 @@ ContinueLoop: MsgBox "处理完成!" & vbCrLf & _ "处理订单数: " & orderCount & vbCrLf & _ - "生成BIP行数: " & outputData.Count & vbCrLf & _ + "生成BIP行数: " & outputData.count & vbCrLf & _ "用时: " & Format(elapsedTime, "0.00") & "秒", vbInformation ' 激活BIP上传模板 @@ -150,7 +153,7 @@ ContinueLoop: Exit Sub ErrorHandler: - MsgBox "处理异常: " & Err.description, vbCritical + MsgBox "处理异常: " & Err.Description, vbCritical End Sub '===================================================================== @@ -165,18 +168,18 @@ End Sub ' 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) + 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 + Dim excludeCats As New Collection excludeCats.Add "部件" BomExtractor.SetExcludeCategories excludeCats End If @@ -188,15 +191,15 @@ Private Sub ProcessSingleOrder(orderNumber As String, _ Dim extractNote As String extractNote = "" - If Not parser.Parse(productModel) Then + If Not parser.Parse(ProductModel) Then ' 解析失败，添加一行错误记录 extractNote = "解析失败: " & parser.ErrorMessage - outputData.Add CreateBIPRowArray(orderNumber, productCode, quantity, 1, "", extractNote) + outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, 1, "", extractNote) Exit Sub End If ' 提取BOM - Dim matchedItems As collection + Dim matchedItems As Collection Set matchedItems = BomExtractor.ExtractBom(parser.Conditions) ' 获取错误信息 @@ -207,12 +210,12 @@ Private Sub ProcessSingleOrder(orderNumber As String, _ End If ' 输出结果 - If matchedItems.Count = 0 Then + If matchedItems.count = 0 Then ' 没有匹配项，添加一行空记录 If extractNote = "" Then extractNote = "未匹配到任何物料" End If - outputData.Add CreateBIPRowArray(orderNumber, productCode, quantity, 1, "", extractNote) + outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, 1, "", extractNote) Else ' 输出每个匹配的物料 Dim item As BomItem @@ -230,7 +233,7 @@ Private Sub ProcessSingleOrder(orderNumber As String, _ End If ' 创建BIP行数据并添加到集合 - outputData.Add CreateBIPRowArray(orderNumber, productCode, quantity, _ + outputData.Add CreateBIPRowArray(orderNumber, productCode, Quantity, _ lineIndex, item.Code66, itemNote) lineIndex = lineIndex + 1 @@ -251,7 +254,7 @@ End Sub '===================================================================== Private Function CreateBIPRowArray(orderNumber As String, _ productCode As String, _ - quantity As String, _ + Quantity As String, _ lineIndex As Long, _ materialCode As String, _ note As String) As Variant() @@ -259,13 +262,13 @@ Private Function CreateBIPRowArray(orderNumber As String, _ rowData(1) = orderNumber ' 来源单据号（生产订单号） rowData(2) = productCode ' 产品编码 - rowData(3) = quantity ' 生产数量 + rowData(3) = Quantity ' 生产数量 rowData(4) = ROW_NUMBER_BASE + lineIndex ' 行号 = 基数 + 索引 rowData(5) = materialCode ' 材料编码（66编码） rowData(6) = "一般发料" ' 供应方式（固定值） rowData(7) = Date ' 需用日期（当天日期） - rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值） - rowData(9) = quantity ' 计划出库数量（与生产数量一致） + rowData(8) = "重庆布莱迪仪器仪表有限公司" ' 发料组织（固定值） + rowData(9) = Quantity ' 计划出库数量（与生产数量一致） rowData(10) = note ' 备注 CreateBIPRowArray = rowData @@ -277,15 +280,15 @@ End Function ' 参数: ws - 工作表对象 ' outputData - 输出数据集合，每个元素是一个一维数组 '===================================================================== -Private Sub WriteBatchData(ws As Worksheet, outputData As collection) +Private Sub WriteBatchData(ws As Worksheet, outputData As Collection) ' 如果没有数据，直接返回 - If outputData.Count = 0 Then + If outputData.count = 0 Then Exit Sub End If ' 创建二维数组 Dim rowCount As Long - rowCount = outputData.Count + rowCount = outputData.count Dim resultData() As Variant ReDim resultData(1 To rowCount, 1 To 10) @@ -358,7 +361,7 @@ Private Function GetBIPUploadSheet() As Worksheet If GetBIPUploadSheet Is Nothing Then ' 创建新工作表 - Set GetBIPUploadSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)) + Set GetBIPUploadSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.count)) GetBIPUploadSheet.Name = wsName End If End Function @@ -382,7 +385,7 @@ End Function Private Sub ClearBIPSheetData(ws As Worksheet) ' 清空从第2行开始的所有数据 Dim lastRow As Long - lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).row + lastRow = ws.Cells(ws.Rows.count, 1).End(xlUp).row If lastRow > 1 Then ws.Rows("2:" & lastRow).ClearContents diff --git a/VBA/Modules/ComponentInventoryCheckModule.bas b/VBA/Modules/ComponentInventoryCheckModule.bas index eb476ca..a591d0a 100644 --- a/VBA/Modules/ComponentInventoryCheckModule.bas +++ b/VBA/Modules/ComponentInventoryCheckModule.bas @@ -66,21 +66,21 @@ Public Sub CheckComponentInventory() Exit Sub End If - ' 检查订单数据 + ' 检查订单数据 (调整为按C列:产品型号获取最后一行) Dim lastRow As Long - lastRow = orderSheet.Cells(orderSheet.Rows.Count, 2).End(xlUp).Row + lastRow = orderSheet.Cells(orderSheet.Rows.count, 3).End(xlUp).row If lastRow < 2 Then MsgBox "[产品订单]工作表没有数据!", vbExclamation Exit Sub End If ' 初始化BOM提取器 - Dim bomExtractor As BomExtractor - Set bomExtractor = New BomExtractor - bomExtractor.SetWorksheet bomSheet + Dim BomExtractor As BomExtractor + Set BomExtractor = New BomExtractor + BomExtractor.SetWorksheet bomSheet - If Not bomExtractor.LoadBomData Then - MsgBox "加载BOM数据失败:" & bomExtractor.GetErrorSummary, vbCritical + If Not BomExtractor.LoadBomData Then + MsgBox "加载BOM数据失败:" & BomExtractor.GetErrorSummary, vbCritical Exit Sub End If @@ -88,7 +88,7 @@ Public Sub CheckComponentInventory() Dim inventoryData As Object Set inventoryData = LoadInventoryData(inventorySheet) - If inventoryData.Count = 0 Then + If inventoryData.count = 0 Then MsgBox "[现存量]工作表没有有效数据!", vbExclamation Exit Sub End If @@ -97,19 +97,19 @@ Public Sub CheckComponentInventory() Dim orders As Collection Set orders = LoadOrderData(orderSheet) - If orders.Count = 0 Then + If orders.count = 0 Then MsgBox "没有有效的订单数据!", vbExclamation Exit Sub End If ' 解析所有订单的BOM - ParseAllOrdersBOM orders, bomExtractor + ParseAllOrdersBOM orders, BomExtractor ' 统计部件总需求 Dim componentDemands As Object Set componentDemands = CalculateComponentDemand(orders) - If componentDemands.Count = 0 Then + If componentDemands.count = 0 Then MsgBox "没有订单包含'部件'类别物料,无需处理库存!", vbInformation Exit Sub End If @@ -138,7 +138,7 @@ Public Sub CheckComponentInventory() resultMsg = resultMsg & vbCrLf & "耗时: " & Format(elapsedTime, "0.00") & "秒" ' 显示警告信息（如果有） - If validationWarnings.Count > 0 Then + If validationWarnings.count > 0 Then resultMsg = resultMsg & vbCrLf & vbCrLf & "警告信息:" & vbCrLf resultMsg = resultMsg & JoinCollection(validationWarnings, vbCrLf) End If @@ -160,16 +160,18 @@ End Sub Private Function LoadOrderData(ws As Worksheet) As Collection Set LoadOrderData = New Collection + ' 调整为按C列获取最后一行 Dim lastRow As Long - lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row + lastRow = ws.Cells(ws.Rows.count, 3).End(xlUp).row Dim i As Long For i = 2 To lastRow Dim model As String Dim qty As Variant - model = Trim(ws.Cells(i, 2).Value) ' B列: 产品型号 - qty = ws.Cells(i, 3).Value ' C列: 产品数量 + ' --- 核心修改：列索引向右移1列 --- + model = Trim(ws.Cells(i, 3).value) ' C列: 产品型号 (原B列) + qty = ws.Cells(i, 4).value ' D列: 产品数量 (原C列) ' 跳过空行 If model <> "" Then @@ -178,7 +180,7 @@ Private Function LoadOrderData(ws As Worksheet) As Collection order.Add ORDER_ROW, CLng(i) order.Add ORDER_MODEL, CStr(model) - order.Add ORDER_QUANTITY, CDbl(IIf(IsNull(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_QTY, 0 order.Add ORDER_HAS_COMP, False @@ -200,15 +202,15 @@ Private Function LoadInventoryData(ws As Worksheet) As Object ' 从第4行开始读取(第3行是表头) Dim lastRow As Long - lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row + lastRow = ws.Cells(ws.Rows.count, 2).End(xlUp).row Dim i As Long For i = 4 To lastRow Dim code As String Dim qty As Variant - code = Trim(ws.Cells(i, 2).Value) ' B列: 物料编码 - qty = ws.Cells(i, 10).Value ' J列: 结存主数量 + code = Trim(ws.Cells(i, 2).value) ' B列: 物料编码 + qty = ws.Cells(i, 10).value ' J列: 结存主数量 If code <> "" And Not IsEmpty(qty) Then If Not LoadInventoryData.Exists(code) Then @@ -224,12 +226,12 @@ End Function ' 参数: orders - 订单集合(每个元素是字典) ' bomExtractor - BOM提取器 '===================================================================== -Private Sub ParseAllOrdersBOM(orders As Collection, bomExtractor As BomExtractor) +Private Sub ParseAllOrdersBOM(orders As Collection, BomExtractor As BomExtractor) Dim i As Long - For i = 1 To orders.Count + For i = 1 To orders.count Dim order As Object Set order = orders(i) - ParseOrderBOM order, bomExtractor + ParseOrderBOM order, BomExtractor Next i End Sub @@ -239,7 +241,7 @@ End Sub ' 参数: orderInfo - 订单信息字典(ByRef) ' bomExtractor - BOM提取器 '===================================================================== -Private Sub ParseOrderBOM(ByRef orderInfo As Object, bomExtractor As BomExtractor) +Private Sub ParseOrderBOM(ByRef orderInfo As Object, BomExtractor As BomExtractor) On Error Resume Next ' 解析型号 @@ -253,14 +255,14 @@ Private Sub ParseOrderBOM(ByRef orderInfo As Object, bomExtractor As BomExtracto ' 提取BOM Dim matchedItems As Collection - Set matchedItems = bomExtractor.ExtractBom(parser.Conditions) + Set matchedItems = BomExtractor.ExtractBom(parser.Conditions) ' 查找"部件"类别物料 Dim item As BomItem For Each item In matchedItems If item.category = "部件" Then orderInfo(ORDER_COMP_CODE) = item.Code66 - orderInfo(ORDER_COMP_QTY) = item.quantity + orderInfo(ORDER_COMP_QTY) = item.Quantity orderInfo(ORDER_HAS_COMP) = True Exit For End If @@ -278,7 +280,7 @@ Private Function CalculateComponentDemand(orders As Collection) As Object Set demands = CreateObject("Scripting.Dictionary") Dim i As Long - For i = 1 To orders.Count + For i = 1 To orders.count Dim order As Object Set order = orders(i) @@ -355,14 +357,14 @@ Private Sub AllocateInventory(orders As Collection, _ ByRef stats As Statistics) ' 初始化统计 - stats.TotalOrders = orders.Count + stats.TotalOrders = orders.count stats.OrdersWithComponent = 0 stats.OrdersSufficient = 0 stats.OrdersInsufficient = 0 stats.OrdersSkipped = 0 Dim i As Long - For i = 1 To orders.Count + For i = 1 To orders.count Dim order As Object Set order = orders(i) @@ -400,8 +402,9 @@ Private Sub AllocateInventory(orders As Collection, _ compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty stats.OrdersSufficient = stats.OrdersSufficient + 1 Else + ' --- 核心修改：回填结果写入F列(第6列) --- ' 库存不足,标记为"否" - orderSheet.Cells(order(ORDER_ROW), 5).Value = "否" + orderSheet.Cells(order(ORDER_ROW), 6).value = "否" compInv(INV_STOCK) = compInv(INV_STOCK) - requiredQty stats.OrdersInsufficient = stats.OrdersInsufficient + 1 End If @@ -467,4 +470,4 @@ Private Function JoinCollection(coll As Collection, separator As String) As Stri Next item JoinCollection = result -End Function +End Function \ No newline at end of file diff --git a/VBA/Modules/MainModule.bas b/VBA/Modules/MainModule.bas index babaee0..5ec723b 100644 --- a/VBA/Modules/MainModule.bas +++ b/VBA/Modules/MainModule.bas @@ -56,14 +56,14 @@ Public Sub ProcessProductModels() ' 处理每个产品型号 Dim lastRow As Long - lastRow = inputSheet.Cells(inputSheet.Rows.Count, 1).End(xlUp).row + lastRow = inputSheet.Cells(inputSheet.Rows.count, 1).End(xlUp).row ' 写入输出表头 WriteOutputHeader outputSheet ' 收集所有输出数据 - Dim outputData As collection - Set outputData = New collection + Dim outputData As Collection + Set outputData = New Collection Dim i As Long Dim modelString As String @@ -71,23 +71,27 @@ Public Sub ProcessProductModels() processedCount = 0 - ' 假设产品型号在第1列,从第2行开始 + ' 假设数据从第2行开始 For i = 2 To lastRow + Dim totalQueueNum As String Dim orderNumber As String - orderNumber = Trim(inputSheet.Cells(i, 1).value) ' A列：生产订单号 - modelString = Trim(inputSheet.Cells(i, 2).value) Dim componentPriority As String - componentPriority = Trim(inputSheet.Cells(i, 5).value) ' E列：部件优先 + + ' --- 核心修改：调整列索引以适应新增的“总排号” --- + 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列右移一列) If modelString <> "" Then - ' 处理单个型号，收集数据 - ProcessSingleModel orderNumber, modelString, componentPriority, BomExtractor, outputData + ' 处理单个型号，收集数据，增加 totalQueueNum 参数 + ProcessSingleModel totalQueueNum, orderNumber, modelString, componentPriority, BomExtractor, outputData processedCount = processedCount + 1 End If Next i ' 批量写入数据到工作表 - If outputData.Count > 0 Then + If outputData.count > 0 Then WriteBatchData outputSheet, outputData End If @@ -107,7 +111,7 @@ Public Sub ProcessProductModels() Exit Sub ErrorHandler: - MsgBox "处理异常: " & Err.description, vbCritical + MsgBox "处理异常: " & Err.Description, vbCritical End Sub '===================================================================== @@ -119,17 +123,18 @@ End Sub ' bomExtractor - BOM提取器对象 ' outputData - 输出数据集合 '===================================================================== -Private Sub ProcessSingleModel(orderNumber As String, _ - modelString As String, _ - componentPriority As String, _ - BomExtractor As BomExtractor, _ - outputData As collection) +Private Sub ProcessSingleModel(totalQueueNum As String, _ + orderNumber As String, _ + modelString 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 + Dim excludeCats As New Collection excludeCats.Add "部件" BomExtractor.SetExcludeCategories excludeCats End If @@ -144,12 +149,12 @@ Private Sub ProcessSingleModel(orderNumber As String, _ If Not parser.Parse(modelString) Then ' 解析失败 extractNote = "解析失败: " & parser.ErrorMessage - outputData.Add CreateOutputRowArray(orderNumber, modelString, parser.Conditions, extractNote, Nothing) + outputData.Add CreateOutputRowArray(totalQueueNum, orderNumber, modelString, parser.Conditions, extractNote, Nothing) Exit Sub End If ' 提取BOM - Dim matchedItems As collection + Dim matchedItems As Collection Set matchedItems = BomExtractor.ExtractBom(parser.Conditions) ' 获取错误信息 @@ -160,12 +165,12 @@ Private Sub ProcessSingleModel(orderNumber As String, _ End If ' 输出结果 - If matchedItems.Count = 0 Then + If matchedItems.count = 0 Then ' 没有匹配项 If extractNote = "" Then extractNote = "未匹配到任何物料" End If - outputData.Add CreateOutputRowArray(orderNumber, modelString, parser.Conditions, extractNote, Nothing) + outputData.Add CreateOutputRowArray(totalQueueNum, orderNumber, modelString, parser.Conditions, extractNote, Nothing) Else ' 输出每个匹配的物料 Dim item As BomItem @@ -183,10 +188,12 @@ Private Sub ProcessSingleModel(orderNumber As String, _ End If If isFirst Then - outputData.Add CreateOutputRowArray(orderNumber, modelString, parser.Conditions, itemNote, item) + ' 首行保留总排号和订单号 + outputData.Add CreateOutputRowArray(totalQueueNum, orderNumber, modelString, parser.Conditions, itemNote, item) isFirst = False Else - outputData.Add CreateOutputRowArray("", modelString, parser.Conditions, itemNote, item) + ' 同一个型号的后续BOM项，总排号和订单号留空以保持报表整洁 + outputData.Add CreateOutputRowArray("", "", modelString, parser.Conditions, itemNote, item) End If Next item End If @@ -201,6 +208,8 @@ Private Sub WriteOutputHeader(ws As Worksheet) Dim col As Long 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 @@ -236,19 +245,20 @@ End Sub ' item - BOM项(可为Nothing) ' 返回: Variant() - 行数据数组 '===================================================================== -Private Function CreateOutputRowArray(orderNumber As String, _ - FullModel As String, _ - Conditions As Object, _ - note As String, _ - item As BomItem) As Variant() +Private Function CreateOutputRowArray(totalQueueNum As String, _ + orderNumber As String, _ + FullModel 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 + ' 计算总列数：3 (排号+订单+型号) + 条件数 + 8 (BOM+备注) Dim totalCols As Long - totalCols = 2 + (UBound(condNames) - LBound(condNames) + 1) + 8 + totalCols = 3 + (UBound(condNames) - LBound(condNames) + 1) + 8 ' 创建数组 ReDim rowData(1 To totalCols) As Variant @@ -256,7 +266,8 @@ Private Function CreateOutputRowArray(orderNumber As String, _ Dim col As Long col = 1 - ' 生产订单号和产品型号 + ' 基础信息 + rowData(col) = totalQueueNum: col = col + 1 rowData(col) = orderNumber: col = col + 1 rowData(col) = FullModel: col = col + 1 @@ -277,7 +288,7 @@ Private Function CreateOutputRowArray(orderNumber As String, _ 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.Quantity: col = col + 1 rowData(col) = item.category: col = col + 1 rowData(col) = item.Code66: col = col + 1 Else @@ -290,16 +301,15 @@ Private Function CreateOutputRowArray(orderNumber As String, _ CreateOutputRowArray = rowData End Function - '===================================================================== ' 过程: WriteBatchData ' 功能: 批量写入数据到工作表 ' 参数: ws - 工作表对象 ' outputData - 输出数据集合 '===================================================================== -Private Sub WriteBatchData(ws As Worksheet, outputData As collection) +Private Sub WriteBatchData(ws As Worksheet, outputData As Collection) ' 如果没有数据，直接返回 - If outputData.Count = 0 Then + If outputData.count = 0 Then Exit Sub End If @@ -309,7 +319,7 @@ Private Sub WriteBatchData(ws As Worksheet, outputData As collection) Dim rowCount As Long Dim colCount As Long - rowCount = outputData.Count + rowCount = outputData.count colCount = UBound(firstRow) - LBound(firstRow) + 1 ' 创建二维数组 diff --git a/VBA/Modules/TestModule.bas b/VBA/Modules/TestModule.bas index 4640bca..d44583a 100644 --- a/VBA/Modules/TestModule.bas +++ b/VBA/Modules/TestModule.bas @@ -234,12 +234,12 @@ Public Sub TestBomExtractor() testConditions.Add "jycz", "1" testConditions.Add "lcfw", "M01" - Dim matchedItems As collection + Dim matchedItems As Collection Set matchedItems = extractor.ExtractBom(testConditions) - Debug.Print " 匹配到 " & matchedItems.Count & " 个物料" + Debug.Print " 匹配到 " & matchedItems.count & " 个物料" - If matchedItems.Count > 0 Then + If matchedItems.count > 0 Then Debug.Print " 匹配的物料:" Dim item As BomItem Dim i As Long