CODEWITHSUNDEEP
arraysexceldictionaryvba
Shawn
Shawn

Reputation: 15

Excel VBA - collection/dictionary? how to create unique parent-children category groupings?

I need some help learning how to handle rolling up data by hierarchy groupings in VBA (PivotTables and even tables are not going to be sufficient due to "end-user" limitations).

I have granular data that with three levels of groupings: Parent, Child, Grain. A Parent may have more than 1 Child; and each Child may have more than 1 Grain. I need to take the universe of granular data and perform some calculations and then produce reports a the Parent and Child levels. For illustrative purposes, below are hypothetical structure/layout of source and desired outputs.

I've explored using Dictionaries and Collections, but neither seems to have the ability to restrict to unique/distinct relationships. For example, Dictionary will restrict to distinct Keys but will allow repetitive string values.

For example: Plants: Edible_Or_Not / Classification / Type / item
Edible / Fruit / Apple / Granny Smith
Edible / Fruit / Apple / Red Delicious
Edible / Vegetable / Asparagus / Asparagus
Nonedible / Tree / Maple / Red

Summaries:
1) Edible composed of Fruit and Vegetable
2) Fruit composed of Apple
3) Apple composed of Granny Smith and Red Delicious.

Below are the layouts more accurately representing my data.

Source:|||||
Parent Category Label|Child Category Label|Granular Label|DataPoint1|DataPoint2…|DataPoint3
---|---|---|---|---|---|
String A|String z|string z.g1.g2.g3|5|FALSE|1/1/1960
String A|String y|String y.g1.g2.g3|0|TRUE|1/2/1970
String B|String w|String w.g1.g2.g3|0|TRUE|9/5/1980
String C|String m|String m.g1.g2.g3|100|TRUE|1/1/1949
String C|String m|String m.g1a.g2.g3|2|FALSE|2/14/2008
String C|String n|String n.g1.g2.g3|2|TRUE|1/1/1950
String C|String o|String o.g1.g2.g3|0|FALSE|1/1/1905
String C|String o|String o.g1a.g2a.g3|0|FALSE|3/1/1977
String C|String p|String p.g1.g2.g3|1|FALSE|4/1/2000

Rollup Need Example #1||||
Parent|Distinct Children Count|Child1|Child 2|….Child(# - last)
---|---|---|---|---|
String A|2|String Z|String Y||
String B|1|String w|||
String C|4|String m|String n|...String p|

Rollup Need Example #2||||
Parent|Calculated Value  ->|Sum DataPoint1 if and only if: (DataPoint 2 = "T" OR (inclusive) DataPoint1 <>0 )AND where DataPoint3 >=1/1/1950
---|---|---|---|
A|5||||
B|0||||
C|5||||

Upvotes: 1

Views: 686

Answers (2)

Dick Kusleika
Dick Kusleika

Reputation: 33165

I'm going to assume you have three ListObjects on three sheets in an Excel Workbook.

Sheet1 (tblParent)

Item
A
B
C

Sheet2 (tblChild)

Item    Parent
z       A
y       A
w       B
m       C
n       C
o       C
p       C

Sheet3 (tblGrain)

Grain       Parent  Data1   Data2   Data3
y.g1.g2.g3  y       0       TRUE    1/2/1970
w.g1.g2.g3  w       0       TRUE    9/5/1980
m.g1.g2.g3  m       100     TRUE    1/1/1949
n.g1.g2.g3  n       2       TRUE    1/1/1950

I would create six class modules named CParent, CParents, CChild, CChildren, CGrain, CGrains.

CParents

Private mcolParents As Collection

Private Sub Class_Initialize()
    Set mcolParents = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolParents = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolParents.[_NewEnum]
End Property

Public Sub Add(clsParent As CParent)
    If clsParent.ParentID = 0 Then
        clsParent.ParentID = Me.Count + 1
    End If

    mcolParents.Add clsParent, CStr(clsParent.ParentID)
End Sub

Public Property Get Parent(vItem As Variant) As CParent
    Set Parent = mcolParents.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolParents.Count
End Property


Public Sub FillFromRange(ByRef rParents As Range, ByRef rChildren As Range, ByRef rGrains As Range)

    Dim vaParents As Variant
    Dim i As Long
    Dim clsParent As CParent

    vaParents = rParents.Value

    For i = LBound(vaParents, 1) To UBound(vaParents, 1)
        Set clsParent = New CParent
        With clsParent
            .Name_ = vaParents(i, 1)
        End With
        Me.Add clsParent

        clsParent.Children.FillFromRange rChildren, clsParent.Name_, rGrains

    Next i

End Sub

CParent

Private mlParentID As Long
Private msName_ As String
Private mclsChildren As CChildren

Public Property Set Children(ByVal clsChildren As CChildren): Set mclsChildren = clsChildren: End Property
Public Property Get Children() As CChildren: Set Children = mclsChildren: End Property
Public Property Let ParentID(ByVal lParentID As Long): mlParentID = lParentID: End Property
Public Property Get ParentID() As Long: ParentID = mlParentID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property

Private Sub Class_Initialize()
    Set mclsChildren = New CChildren
End Sub

Private Sub Class_Terminate()
    Set mclsChildren = Nothing
End Sub

CChildren

Private mcolChildren As Collection

Private Sub Class_Initialize()
    Set mcolChildren = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolChildren = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolChildren.[_NewEnum]
End Property

Public Sub Add(clsChild As CChild)
    If clsChild.ChildID = 0 Then
        clsChild.ChildID = Me.Count + 1
    End If

    mcolChildren.Add clsChild, CStr(clsChild.ChildID)
End Sub

Public Property Get Child(vItem As Variant) As CChild
    Set Child = mcolChildren.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolChildren.Count
End Property

Public Sub FillFromRange(ByRef rRng As Range, ByVal sParentName As String, ByRef rGrains As Range)

    Dim vaValues As Variant
    Dim i As Long
    Dim clsChild As CChild

    vaValues = rRng.Value

    For i = LBound(vaValues, 1) To UBound(vaValues, 1)
        If vaValues(i, 2) = sParentName Then
            Set clsChild = New CChild
            With clsChild
                .Name_ = vaValues(i, 1)
            End With
            Me.Add clsChild

            clsChild.Grains.FillFromRange rGrains, clsChild.Name_
        End If
    Next i

End Sub

CChild

Private mlChildID As Long
Private msName_ As String
Private mclsGrains As CGrains

Public Property Set Grains(ByVal clsGrains As CGrains): Set mclsGrains = clsGrains: End Property
Public Property Get Grains() As CGrains: Set Grains = mclsGrains: End Property
Public Property Let ChildID(ByVal lChildID As Long): mlChildID = lChildID: End Property
Public Property Get ChildID() As Long: ChildID = mlChildID: End Property
Public Property Let Name_(ByVal sName_ As String): msName_ = sName_: End Property
Public Property Get Name_() As String: Name_ = msName_: End Property

Private Sub Class_Initialize()
    Set mclsGrains = New CGrains
End Sub

Private Sub Class_Terminate()
    Set mclsGrains = Nothing
End Sub

CGrains

Private mcolGrains As Collection

Private Sub Class_Initialize()
    Set mcolGrains = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolGrains = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolGrains.[_NewEnum]
End Property

Public Sub Add(clsGrain As CGrain)
    If clsGrain.GrainID = 0 Then
        clsGrain.GrainID = Me.Count + 1
    End If

    mcolGrains.Add clsGrain, CStr(clsGrain.GrainID)
End Sub

Public Property Get Grain(vItem As Variant) As CGrain
    Set Grain = mcolGrains.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolGrains.Count
End Property

Public Sub FillFromRange(ByRef rRng As Range, ByVal sChildName As String)

    Dim vaValues As Variant
    Dim i As Long
    Dim clsGrain As CGrain

    vaValues = rRng.Value

    For i = LBound(vaValues, 1) To UBound(vaValues, 1)
        If vaValues(i, 2) = sChildName Then
            Set clsGrain = New CGrain
            With clsGrain
                .Data1 = vaValues(i, 3)
                .Data2 = vaValues(i, 4)
                .Data3 = vaValues(i, 5)
            End With
            Me.Add clsGrain
        End If
    Next i

End Sub

CGrain

Private mlGrainID As Long
Private mlData1 As Long
Private mbData2 As Boolean
Private mdtData3 As Date

Public Property Let GrainID(ByVal lGrainID As Long): mlGrainID = lGrainID: End Property
Public Property Get GrainID() As Long: GrainID = mlGrainID: End Property
Public Property Let Data1(ByVal lData1 As Long): mlData1 = lData1: End Property
Public Property Get Data1() As Long: Data1 = mlData1: End Property
Public Property Let Data2(ByVal bData2 As Boolean): mbData2 = bData2: End Property
Public Property Get Data2() As Boolean: Data2 = mbData2: End Property
Public Property Let Data3(ByVal dtData3 As Date): mdtData3 = dtData3: End Property
Public Property Get Data3() As Date: Data3 = mdtData3: End Property

All this has done so far is to create three objects, establish relationships between them, and provide a way to fill them with data from an Excel range.

The relationships are established in the single object classes (not the plural ones). The CParent class has a property that holds a CChildren collection class. All of the children for that parent are stored in that class. The CChildren class holds a bunch of CChild objects. Each CChild object has a property CGrains that holds all the grains for that child. This is a lot of setup, but the payoff is coming.

Next, in a standard module, I want to create the procedure that fills the classes.

Public gclsParents As CParents

Public Sub Initialize()

    Set gclsParents = New CParents
    gclsParents.FillFromRange Sheet1.ListObjects(1).DataBodyRange, Sheet2.ListObjects(1).DataBodyRange, Sheet3.ListObjects(1).DataBodyRange

End Sub

I create a Public variable for the top collection class so it doesn't go out of scope. In Intialize, I instantiate the top collection class variable and call the FillFromRange method. I pass it my three Excel tables and the code fills in the all the classes.

Now lets say you wanted to create a procedure that listed all parents, a count of their children, and a list of their children.

Public Sub ListChildren()

    Dim sh As Worksheet
    Dim vaWrite As Variant

    If gclsParents Is Nothing Then Initialize

    Set sh = ThisWorkbook.Worksheets.Add
    vaWrite = gclsParents.ChildListToRange

    sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite

End Sub

My CParents instance (held in gclsParents) returns an array that is dumped to a new sheet. The output looks like

A   2   z,y
B   1   w
C   4   m,n,o,p

Now you have to create the ChildListToRange method. Add this to the CParents class

Public Property Get ChildListToRange() As Variant

    Dim aReturn() As Variant
    Dim clsParent As CParent
    Dim lCnt As Long

    ReDim aReturn(1 To Me.Count, 1 To 3)

    For Each clsParent In Me
        lCnt = lCnt + 1
        aReturn(lCnt, 1) = clsParent.Name_
        aReturn(lCnt, 2) = clsParent.Children.Count
        aReturn(lCnt, 3) = clsParent.ChildListDelimited(",")
    Next clsParent

    ChildListToRange = aReturn

End Property

The first two columns in the array are already defined, but we need to create a ChildListDelimited property in the CParent class. Add this to CParent

Public Property Get ChildListDelimited(ByVal sDelim As String) As String

    Dim clsChild As CChild
    Dim aReturn() As String
    Dim lCnt As Long

    ReDim aReturn(1 To Me.Children.Count)

    For Each clsChild In Me.Children
        lCnt = lCnt + 1
        aReturn(lCnt) = clsChild.Name_
    Next clsChild

    ChildListDelimited = Join(aReturn, sDelim)

End Property

You supply a delimiter, this property returns a string of all the children separated by that delimiter.

And that's it. Your first report is done. Next, you want to create a report that sums up Data1 with certain criteria. Create this procedure in a standard module

Public Sub SummarizeValues()

    Dim sh As Worksheet
    Dim vaWrite As Variant
    Dim clsToSum As CParents

    If gclsParents Is Nothing Then Initialize

    Set sh = ThisWorkbook.Worksheets.Add
    Set clsToSum = gclsParents.FilterByData2(True).FilterByData3(DateSerial(1950, 1, 1), ">=")
    vaWrite = clsToSum.SummarizeGrainValues

    sh.Range("A1").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite

End Sub

That looks a lot like the first procedure except that the CParents property that returns the array (to be written to a worksheet) is different. Also, we do some filtering. In the first procedure, we wanted every parent. Now we only want parents that meet certain criteria. For that, create a couple of FilterBy properties. In CParents add

    Public Property Get FilterByData2(ByVal lData As Long) As CParents

        Dim clsParent As CParent
        Dim clsNewParent As CParent
        Dim clsChild As CChild
        Dim clsReturn As CParents

        Set clsReturn = New CParents

        For Each clsParent In Me
            Set clsNewParent = New CParent
            clsNewParent.Name_ = clsParent.Name_
            Set clsNewParent.Children = clsParent.Children.FilterByData2(lData)
            If clsNewParent.Children.Count > 0 Then
                clsReturn.Add clsNewParent
            End If
        Next clsParent

        Set FilterByData2 = clsReturn

    End Property

This is a common filtering property. It takes a big CParents instance (gclsParents in this case) and returns a smaller one. If it finds children that meet the criteria, it adds the parent to the return class. Otherwise it doesn't. But you'll need to pass that criteria down to the children. Add this to the CChildren class

Public Property Get FilterByData2(ByVal lData As Long) As CChildren

    Dim clsChild As CChild
    Dim clsNewChild As CChild
    Dim clsGrain As CGrain
    Dim clsReturn As CChildren

    Set clsReturn = New CChildren

    For Each clsChild In Me
        Set clsNewChild = New CChild
        clsNewChild.Name_ = clsChild.Name_
        Set clsNewChild.Grains = clsChild.Grains.FilterByData2(lData)
        If clsNewChild.Grains.Count > 0 Then
            clsReturn.Add clsNewChild
        End If
    Next clsChild

    Set FilterByData2 = clsReturn

End Property

And add this to the CGrains class

Public Property Get FilterByData2(ByVal lData As Long) As CGrains

    Dim clsGrain As CGrain
    Dim clsReturn As CGrains

    Set clsReturn = New CGrains

    For Each clsGrain In Me
        If clsGrain.Data2 = lData Then
            clsReturn.Add clsGrain
        End If
    Next clsGrain

    Set FilterByData2 = clsReturn

End Property

All that returns a CParents instance with the only the parents that eventually have a grain with true in Data2.

From that already smaller CParents instance, we tack on another filter. Add this to CParents

Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CParents

    Dim clsParent As CParent
    Dim clsNewParent As CParent
    Dim clsChild As CChild
    Dim clsReturn As CParents

    Set clsReturn = New CParents

    For Each clsParent In Me
        Set clsNewParent = New CParent
        clsNewParent.Name_ = clsParent.Name_
        Set clsNewParent.Children = clsParent.Children.FilterByData3(dtData, sComp)
        If clsNewParent.Children.Count > 0 Then
            clsReturn.Add clsNewParent
        End If
    Next clsParent

    Set FilterByData3 = clsReturn

End Property

Because this filter uses an inequality, it gets a little more complicated as we'll see in a minute. For now, add this to CChildren

Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CChildren

    Dim clsChild As CChild
    Dim clsNewChild As CChild
    Dim clsGrain As CGrain
    Dim clsReturn As CChildren

    Set clsReturn = New CChildren

    For Each clsChild In Me
        Set clsNewChild = New CChild
        clsNewChild.Name_ = clsChild.Name_
        Set clsNewChild.Grains = clsChild.Grains.FilterByData3(dtData, sComp)
        If clsNewChild.Grains.Count > 0 Then
            clsReturn.Add clsNewChild
        End If
    Next clsChild

    Set FilterByData3 = clsReturn

End Property

And add this to CGrains

Public Property Get FilterByData3(ByVal dtData As Date, ByVal sComp As String) As CGrains

    Dim clsGrain As CGrain
    Dim clsReturn As CGrains
    Dim bAdd As Boolean

    Set clsReturn = New CGrains

    For Each clsGrain In Me
        Select Case sComp
            Case ">="
                bAdd = clsGrain.Data3 >= dtData
            Case ">"
                bAdd = clsGrain.Data3 > dtData
            Case "<"
                bAdd = clsGrain.Data3 < dtData
            Case "<="
                bAdd = clsGrain.Data3 <= dtData
            Case Else
                bAdd = clsGrain.Data3 = dtData
        End Select

        If bAdd Then
            clsReturn.Add clsGrain
        End If
    Next clsGrain

    Set FilterByData3 = clsReturn

End Property

You can see in CGrains that I have to use a Select Case to figure out what inequality you want. But other that wrinkle, it does the same thing as the first filter.

Now you have a variable clsToSum that is a CParents instance that only contains parents you want. You've already done the filtering, now all you have to do it sum stuff up. Add this to CParents

Public Property Get SummarizeGrainValues() As Variant

    Dim clsParent As CParent
    Dim aReturn() As Variant
    Dim lCnt As Long

    ReDim aReturn(1 To Me.Count, 1 To 2)

    For Each clsParent In Me
        lCnt = lCnt + 1
        aReturn(lCnt, 1) = clsParent.Name_
        aReturn(lCnt, 2) = clsParent.SumData1
    Next clsParent

    SummarizeGrainValues = aReturn

End Property

Now you have to add SumData1 to CParent

Public Property Get SumData1() As Long

    Dim lReturn As Long
    Dim clsChild As CChild
    Dim clsGrain As CGrain

    For Each clsChild In Me.Children
        For Each clsGrain In clsChild.Grains
            lReturn = lReturn + clsGrain.Data1
        Next clsGrain
    Next clsChild

    SumData1 = lReturn

End Property

That loops through all the grains in all the children and adds them up. The output looks like

A   0
B   0
C   2

Now that the infrastructure is done, you can create any manner of report you want. You simply have to set up whatever filters you need and any aggregation properties you want to report.

I probably should have said this at the top, but if you put these three tables in a proper relational database, you can accomplish all this with two fairly short SQL statements.

If you want to see it all together in a workbook, download this http://dailydoseofexcel.com/excel/ClassParentChildGrains.zip

Upvotes: 1

Zerk
Zerk

Reputation: 1593

Custom classes would allow you to create a hierarchy, the example class below is to get you started.

A parent object can place child objects within the container collection and then perform rollup calculations aggregating all objects within the collection.

Assuming you place child objects within the collection you could place grain objects within their container also and create a hierarchy as suits.

Private pContainer As New Collection
Private pTitle As String
Private pValueToSum As Double
Public Property Get Container() As Collection
Set Container = pContainer
End Property
Public Property Let Container(value As Collection)
Set pContainer = value
End Property
Public Property Get GetTotals() As Double
Dim dbl As Double
Dim var As Variant

For Each var In Me.Container
    dbl = dbl + var.ValueToSum
Next var

GetTotals = dbl
End Property

Upvotes: 0

Related Questions