VBA:使用类模块/集合和/或动态数组？

Question

我的问题:

我有多个产品结构需要能够通读。我不知道产品结构会深入到多少层。例如，我可以有以下内容:

产品 A 使用以下组件

• A1
• A2
• A3
• A4

但是组件 A3 可能是一个子组件，它有自己的产品结构，需要拉动。因此，我最终会得到产品 A 的完整产品结构，如下所示:

A用途:

• A1
• A2
• A3(使用以下组件):
  • A3A
  • A3B(使用以下组件):*A3B1*A3B2*A3B3
  • A3C
  • A3D
• A4

等等。

我当前的代码使用一个数组来包含通过数据库查询检索到的信息，如下所示

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 列为父组件，并列出了组件。

数据库表如何查找此内容的示例如下:

Plant    |    Parent    |    Component    |    NumberUsedZ        |    A         |    A1           |    1Z        |    A         |    A2           |    3Z        |    A         |    A3           |    1Z        |    A         |    A4           |    2Z        |    A3        |    A3A          |    1Z        |    A3        |    A3B          |    1Z        |    A3        |    A3C          |    2Z        |    A3        |    A3D          |    1Z        |    A3B       |    A3B1         |    1Z        |    A3B       |    A3B2         |    4Z        |    A3B       |    A3B3         |    1

Answer 1

这是一个很长的答案，但也许会有帮助

我提供了 2 个版本来说明嵌套字典在您的案例中的使用

测试数据(主要部分为浅橙色):

<小时/>

Version 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()
• 第二个按行生成嵌套字典(递归):SetItms()
  • col B(父级)- lvl 1 - 这些项目是顶级字典中的键
  • col C(组件)- lvl 2 - 顶级词典的值和子词典的键
  • col D (NumberUsed) - lvl 3 - 每个子词典中的值

<小时/>

This uses dictionaries and late binding is slow: CreateObject("Scripting.Dictionary")

Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime

<小时/>

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 个子函数仅用于从字典中输出数据: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

<小时/>

Version 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 只是创建 2 级字典嵌套(第 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 开始，并且是连续的