CODEWITHSUNDEEP
vbaexcel
Glenn G
Glenn G

Reputation: 667

VBA: Use Class module / Collection and/or dynamic array?

My problem:

I have multiple product structures that I need to be able to read through. I do not know ahead of time how many levels deep the product structure goes. For Example I could have the following:

Product A uses the following components

but component A3 may be a sub assembly which has its own product structure that would need to be pulled. So I would then end up with the complete product structure for Product A looking like the following:

A uses:

and so on.

My current code uses an array to contain the information retrieved via a DB query as shown here

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

The problem I have with this is that it isn't capable of going further than 1 layer deep on the product structure, which means it won't pull the information for sub-assemblies. I think I want to use a class module and a collection to over come this but I can't quite wrap my head around it.

The information for the product structure of the sub assembly A3 is listed in the ProdStructMstr table with A3 listed as the Parent and the components listed.

An example of how the DB table looks for this would be:

Plant    |    Parent    |    Component    |    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

Upvotes: 2

Views: 1118

Answers (2)

paul bica
paul bica

Reputation: 10715

This is a long answer, but maybe it will help

I'm providing 2 versions to illustrate the use of nested dictionaries for your case

Test data (main section is light-orange):

enter image description here

Version 1

Output:

------ 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

Version 1 has two main procedures

  • one that reads all rows from Sheet1: ReadData()
  • the second generates nested dictionaries (recursively) by rows: SetItms()
    • col B (Parent) - lvl 1 - These items are Keys in the top-level dictionary
    • col C (Component) - lvl 2 - Values of top-level dictionary, and Keys for sub-dictionaries
    • col D (NumberUsed) - lvl 3 - Values in each sub-dictionary

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

The next 2 subs are only used to output data from dictionaries: ShowAllData() and 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

Output:

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

Version 2 simply creates a 2-level nesting of dictionaries (level 1 = rows, level 2 = columns)

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

Notes:

  • you could place all procedures (both versions) in the same module
  • this assumes that UsedRange on Sheet1 starts at cell A1, and is contiguous

Upvotes: 1

J. Garth
J. Garth

Reputation: 803

I suspect the problem is that you are tying to query your mainframe database as if it were a relational database. But based on the example table you provided, it's not. That table is not normalized.

So I'm guessing that in your sql query,

"SELECT Component, NumberUsed FROM ProdStructMstr WHERE (((Parent)='" & ParentName & "') AND ((Plant)='" & Plt & "')) ORDER BY Component;"

Parent probably equals "A" and so the recordset you are getting back only consists of components A1, A2, A3, & A4.

If that is the case, then you need to change the SQL query to use the Like keyword as below (you may have to adjust the syntax)

"SELECT Component, NumberUsed FROM ProdStructMstr WHERE (((Parent)=Like '" & ParentName & " *') AND ((Plant)='" & Plt & "')) ORDER BY Component;"

This will return all records where the Parent starts with "A", instead of just the records where the Parent equals A. You will end up with a lot of duplicates you will need to filter out but you should at least have all of the data that you need.

Upvotes: 1

Related Questions