Build parent/child hierarchy

[adygelber]

Hello,

I kindly ask for your support because I have to achieve something that seems to be simple but I just can't figure it out how to do it.

Mainly, I have two columns. The first one contains some parent codes, the second one contains some child codes which can consequently become parent codes for other child codes. And so on.

Having this in mind, I want to create a hierarchy like the one from the below example. The example file was created manually with a minimum number of records but the final database can be way bigger.

Parent	Child
AB00000	AB00001		AB00000	AB00001	AB00002	AB00005	AB00009	AB00010
AB00001	AB00002					AB00006
AB00001	AB00003					AB00005
AB00001	AB00004					AB00007
AB00002	AB00005					AB00005
AB00002	AB00006				AB00003	AB00007
AB00002	AB00005				AB00004	AB00008
AB00002	AB00007
AB00002	AB00005
AB00003	AB00007
AB00004	AB00008
AB00005	AB00009
AB00009	AB00010

<colgroup><col style="width:48pt" span="9" width="64"> </colgroup><tbody>
</tbody>

Thank you in advance for your support!
A.B.

Also posted here:
[url]http://www.vbaexpress.com/forum/showthread.php?57247-Build-parent-child-hierarchy
Build parent/child hierarchy
[/URL]

 

[adygelber]

There were some mistakes in the above table, as the same child was allocated to more than one parent and there was also a duplicate record. Please consider this:

Parent	Child
AB00000	AB00001		AB00000	AB00001	AB00002	AB00005	AB00009	AB00010
AB00001	AB00002					AB00006
AB00001	AB00003					AB00007
AB00001	AB00004				AB00003	AB00011
AB00002	AB00005				AB00004	AB00008
AB00002	AB00006
AB00002	AB00007
AB00003	AB00011
AB00004	AB00008
AB00005	AB00009
AB00009	AB00010

<colgroup><col style="width:48pt" span="9" width="64"> </colgroup><tbody>
</tbody>

Thanks!

 

[mikerickson]

You could do something like this:

Insert a Class module and name it clsPCNode

' in clsPCNode class module

Public Name As String
Public Tree As clsPCTree

Public Children As Collection

Function AddChild(ChildsName As String) As clsPCNode
    Set AddChild = Tree.AddNode(ChildsName)
    On Error Resume Next
    Children.Add Item:=AddChild, Key:=AddChild.Name
    On Error GoTo 0
End Function

Sub WriteTo(ByRef StartCell As Range)
    Dim oneChild As clsPCNode
   
    StartCell.Value = Me.Name
    
    If Children.Count = 0 Then
        Set StartCell = StartCell.Offset(1, 0)
    Else
        Set StartCell = StartCell.Offset(0, 1)
        For Each oneChild In Children
            oneChild.WriteTo StartCell
        Next oneChild
        Set StartCell = StartCell.Offset(0, -1)
    End If
End Sub

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

Insert another class module and name it clsPCTree

' in clsPCTree class module

Public Nodes As Collection

Function AddNode(NodeName As String) As clsPCNode
    On Error Resume Next
    Set AddNode = Nodes(NodeName)
    If Err Then
        Set AddNode = New clsPCNode
        AddNode.Name = NodeName
        Set AddNode.Tree = Me
        Nodes.Add Item:=AddNode, Key:=NodeName
    End If
    On Error GoTo 0
End Function

Property Get Count() As Long
    Count = Nodes.Count
End Property

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

And then put code like this in a normal module

Sub test()
    Dim myTree As clsPCTree
    Dim dataRange As Range
    Dim oneCell As Range
    With Sheet1.Range("A:A")
        Set dataRange = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    Set myTree = New clsPCTree
    For Each oneCell In dataRange.Cells
        myTree.AddNode(oneCell.Value).AddChild oneCell.Offset(0, 1).Value
    Next oneCell
    Range("P:T").ClearContents
    myTree.Nodes(1).WriteTo Range("P1")
End Sub

A child having more than one parent is not a problem, but if a person is its own n-child then there is a problem.

 

[adygelber]

Thank you for your quick response Mike,

Unfortunatelly, I receive an "Object variable or With block variable not set" error on line

myTree.Nodes(1).WriteTo Range("P1")

Can you figure it out?

 

[mikerickson]

First, that code is more complicated than needed. I'm at work and can't simplify at the moment. (The key routine in the sum WriteTo)

Second, try naming the top node explicity

myTree.Nodes("AB00000").WriteTo Range("P1")

 

[adygelber]

I still receive the same error, on the same line, after ammending the code with

myTree.Nodes("AB00000").WriteTo Range("P1")

but thank you anyway for trying to help me.
There is no hurry so please take your time and if you will have the possibility to find a solution later, I thank you for this.

 

[adygelber]

I deeply appologise for my mistake. Your original code works just fine but by mistake I didn't copy all the lines.

I thank you very much for your solution and I will give it a try with a more complex database.

I let you know

 

[mikerickson]

This refunded version doesn't need class modules

Sub test()
    WriteDownFrom CStr(ParentDataRange.Cells(1, 1)), Range("G1")
End Sub

Sub WriteDownFrom(ByVal aPerson As String, ByRef WriteTo As Range)
    Dim Children As Collection
    Dim oneCell As Range
    Dim i As Long
    
    Set Children = New Collection
    For Each oneCell In ParentDataRange.Columns(1).Cells
        If LCase(oneCell.Value) = LCase(aPerson) Then
            On Error Resume Next
                Children.Add Item:=oneCell.Offset(0, 1), Key:=CStr(oneCell.Offset(0, 1))
            On Error GoTo 0
        End If
    Next oneCell
    
    WriteTo.Value = aPerson
    
    If Children.Count = 0 Then
        Set WriteTo = WriteTo.Offset(1, 0)
    Else
        Set WriteTo = WriteTo.Offset(0, 1)
        For i = 1 To Children.Count
            WriteDownFrom Children(i), WriteTo
        Next i
        Set WriteTo = WriteTo.Offset(0, -1)
    End If
    
End Sub

Function ParentDataRange() As Range
    With Sheet1.Range("A:A")
        Set ParentDataRange = Range(.Cells(2, 1), .Cells(Rows.Count, 1).End(xlUp))
    End With
    Set ParentDataRange = ParentDataRange.Resize(, 2)
End Function

 

[adygelber]

Hey Mike,

Your solution works perfectly on my example but not on the big database.
Anyway, I think that is something wrong with the database so please allow me one or two working days and I will come back to you with an answer.

Thank you very much for your work,
A.B.

 

[mikerickson]

What does it do wrong with the big data base?