VBA：使用类模块/集合和/或dynamic数组？
我的问题：
我有多个产品结构，我需要能够通读。 事先并不知道产品结构有多深。 例如，我可以有以下几点：
产品A使用以下组件
- A1
- A2
- A3
- A4
但是组件A3可以是具有其自己的产品结构的子组件，其需要被拉动。 所以我最终会看到产品A的完整产品结构，如下所示：
A用途：
- A1
- A2
- A3（使用以下组件）：
- A3A
- A3B（使用以下部件）：* A3B1 * A3B2 * A3B3
- A3C
- A3D
- A4
等等。
我当前的代码使用一个数组来包含通过DB查询检索到的信息，如下所示
Dim NumRecords As Integer Dim X As Integer Dim db As DAO.Database Dim rs As DAO.Recordset Dim sSQL As String Dim PPS() As String 'Product structure returned from database query for the parent item Dim ParentName as String ' Parent Product Dim Plt as String ' Plant of Manufacture Dim DBPath as string 'File path for the database Set db = OpenDatabase(DBPath) sSQL = "SELECT Component, NumberUsed FROM ProdStructMstr WHERE (((Parent)='" & ParentName & "') AND ((Plant)='" & Plt & "')) ORDER BY Component;" Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) rs.MoveLast rs.MoveFirst If Not rs.EOF Then NumRecords = rs.RecordCount If NumRecords > 0 Then ReDim PPS(NumRecords - 1, 1) rs.MoveFirst For X = 0 To NumRecords - 1 PPS(X, 0) = rs!Component PPS(X, 1) = rs!NumberUsed rs.MoveNext Next X Else MsgBox "ERROR: DB Table Empty or Not Found!", vbExclamation, "DATA ERROR" End If Set rs = Nothing Set db = Nothing 我所遇到的问题是产品结构上不能超过1层，这意味着它不会为子组件提供信息。 我想我想使用一个类模块和一个集合来结束这个，但我不能完全包围它。
子部件A3的产品结构的信息列在ProdStructMstr表中，列出了作为父级和列出的组件的A3。
DB表如何查找的例子是：
工厂| 父| | 组件| NumberUsed Z | A | A1 | 1 Z | A | A2 | 3 Z | A | A3 | 1 Z | A | A4 | 2 Z | A3 | A3A | 1 Z | A3 | A3B | 1 Z | A3 | A3C | 2 Z | A3 | A3D | 1 Z | A3B | A3B1 | 1 Z | A3B | A3B2 | 4 Z | A3B | A3B3 | 1
我怀疑问题是，你正在绑定查询您的大型机数据库，就好像它是一个关系数据库。 但是根据你提供的示例表，事实并非如此。 该表格没有正常化。
所以我猜你的SQL查询，
"SELECT Component, NumberUsed FROM ProdStructMstr WHERE (((Parent)='" & ParentName & "') AND ((Plant)='" & Plt & "')) ORDER BY Component;"
Parent可能等于“A”，所以你回来的logging集只包含组件A1，A2，A3和A4。
如果是这样，那么您需要更改SQL查询以使用Like关键字（如下所示）（您可能需要调整语法）
"SELECT Component, NumberUsed FROM ProdStructMstr WHERE (((Parent)=Like '" & ParentName & " *') AND ((Plant)='" & Plt & "')) ORDER BY Component;"
这将返回父“A”所在的所有logging，而不仅仅是“父”等于A的logging。您将得到大量需要过滤掉的重复logging，但您至less应该拥有所有数据你需要的。
这是一个很长的答案，但也许会有所帮助
我提供了2个版本来说明您的案例使用嵌套字典
testing数据（主要部分是浅橙色）：
版本1
输出：
------ ShowAllData Item: A, SubItem: A1, Value: 1 Item: A, SubItem: A2, Value: 3 Item: A, SubItem: A3, Value: 1 Item: A, SubItem: A4, Value: 2 Item: A3, SubItem: A3A, Value: 1 Item: A3, SubItem: A3B, Value: 1 Item: A3, SubItem: A3C, Value: 2 Item: A3, SubItem: A3D, Value: 1 Item: A3B, SubItem: A3B1, Value: 1 Item: A3B, SubItem: A3B2, Value: 4 Item: A3B, SubItem: A3B3, Value: 1 ------ ShowData (A3) Item: A3, SubItem: A3A, Value: 1 Item: A3, SubItem: A3B, Value: 1 Item: A3, SubItem: A3C, Value: 2 Item: A3, SubItem: A3D, Value: 1 ------ ShowData (A3B2) Item: A3B, SubItem: A3B2, Value: 4
版本1有两个主要的程序
- 一个读取Sheet1中的所有行：
ReadData() - 第二个按行（recursion）生成嵌套字典：
SetItms()- col B（Parent） – lvl 1 – 这些项目是顶级词典中的键
- col C（Component） – lvl 2 – 顶级词典的值和子词典的键
- col D（NumberUsed） – lvl 3 – 每个子字典中的值
这使用字典和后期绑定是慢的 ：
CreateObject（“Scripting.Dictionary”）早期绑定是快速的 ：VBA编辑器 – > 工具 – > 引用 – >添加Microsoft脚本运行时
Option Explicit 'In VBA Editor add a reference: Tools -> References -> Add Microsoft Scripting Runtime Private Const SEP = "------ " Public Sub ReadData() Const TLC = 2 'TLC = Top-level column (B: Parent) Dim ur As Variant, r As Long, ubR As Long, parents As Dictionary Dim lvl1 As String, lvl2 As String, lvl3 As String ur = Sheet1.UsedRange ubR = UBound(ur, 1) Set parents = New Dictionary parents.CompareMode = vbTextCompare 'or: vbBinaryCompare For r = 2 To ubR lvl1 = Trim(CStr(ur(r, TLC))) lvl2 = Trim(CStr(ur(r, TLC + 1))) lvl3 = Trim(CStr(ur(r, TLC + 2))) SetItms Array(lvl1, lvl2, lvl3), parents Next ShowAllData parents ShowData parents, "A3" ShowData parents, "A3B2" End Sub
Public Sub SetItms(ByRef itms As Variant, ByRef parents As Dictionary) Dim ub As Long, subItms() As String, i As Long, children As Dictionary ub = UBound(itms) If ub > 1 Then ReDim subItms(ub - 1) For i = 1 To ub subItms(i - 1) = itms(i) Next If Not parents.Exists(itms(0)) Then Set children = New Dictionary children.CompareMode = vbTextCompare 'or: vbBinaryCompare SetItms subItms, children '<-- recursive call parents.Add itms(0), children Else Set children = parents(itms(0)) SetItms subItms, children '<-- recursive call End If Else If Not parents.Exists(itms(0)) Then parents.Add itms(0), itms(1) End If End Sub
接下来的2个subs仅用于从字典输出数据： ShowAllData()和ShowData()
Private Sub ShowAllData(ByRef itms As Dictionary) Dim l1 As Variant, l2 As Variant Debug.Print SEP & "ShowAllData" For Each l1 In itms For Each l2 In itms(l1) Debug.Print "Item: " & l1 & ", SubItem: " & l2 & ", Value: " & itms(l1)(l2) Next Next End Sub Private Sub ShowData(ByRef itms As Dictionary, ByVal itmName As String) Dim l1 As Variant, l2 As Variant, isParent As Boolean, done As Boolean Debug.Print SEP & "ShowData (" & itmName & ")" For Each l1 In itms isParent = l1 = itmName If isParent Then For Each l2 In itms(l1) Debug.Print "Item: " & l1 & ", SubItem: " & l2 & ", Value: " & itms(l1)(l2) Next End If If isParent Then Exit For Next If Not isParent Then For Each l1 In itms For Each l2 In itms(l1) done = l2 = itmName If done Then Debug.Print "Item: " & l1 & ", SubItem: " & l2 & ", Value: " & itms(l1)(l2) Exit For End If Next If done Then Exit For Next End If End Sub
版本2
输出：
Row 1, Col 1: ---> Plant Row 1, Col 2: ---> Parent Row 1, Col 3: ---> Component Row 1, Col 4: ---> NumberUsed Row 1, Col 5: ---> Test Col 1 Row 1, Col 6: ---> Test Col 2 Row 1, Col 7: ---> Test Col 3 Row 2, Col 1: ---> Z Row 2, Col 2: ---> A Row 2, Col 3: ---> A1 Row 2, Col 4: ---> 1 Row 2, Col 5: ---> E1 Row 2, Col 6: ---> F1 Row 2, Col 7: ---> G1 ... Row 12, Col 1: ---> Z Row 12, Col 2: ---> A3B Row 12, Col 3: ---> A3B3 Row 12, Col 4: ---> 1 Row 12, Col 5: ---> E11 Row 12, Col 6: ---> F11 Row 12, Col 7: ---> G11
版本2仅创build2级字典嵌套（级别1 =行，级别2 =列）
Public Sub NestedList() Dim ur As Variant, itms As Dictionary, subItms As Dictionary Dim r As Long, c As Long, lr As Long, lc As Long ur = ThisWorkbook.Worksheets("Sheet1").UsedRange Set itms = New Dictionary itms.CompareMode = vbTextCompare 'or: vbBinaryCompare lr = UBound(ur, 1) lc = UBound(ur, 2) For r = 1 To lr Set subItms = New Dictionary itms.CompareMode = vbTextCompare For c = 1 To lc subItms.Add Key:=c, Item:=Trim(CStr(ur(r, c))) Next itms.Add Key:=r, Item:=subItms Set subItms = Nothing Next NestedListShow itms End Sub Private Sub NestedListShow(ByRef itms As Dictionary) Dim r As Long, c As Long For r = 1 To itms.Count For c = 1 To itms(r).Count Debug.Print "Row " & r & ", Col " & c & ": ---> " & itms(r)(c) Next Next End Sub
笔记：
- 你可以把所有的程序（两个版本）放在同一个模块中
- 这假定Sheet1上的UsedRange从单元格A1开始，并且是连续的