PLEASE HELP ME OUT Parent-Child hierarchy construction

_disha_

New Member
Joined
Dec 22, 2013
Messages
12
Hi,

I am new to VB, saw ur post on providing parent child hierarchy in visually structured way in excel. Hoping that you will help me out in this issue . Please mail me in


ddhisha@gmail.com


There is a table in xl as below:
Calling Called
Folder1 Sub1
Folder1 Sub2
Sub1 Sub3
Sub3 Sub4
Folder2 Sub6
Folder2 Sub7
Sub7 Sub8
Sub7 Sub9


Explaination of the table:
"Folder1" is calling child "Sub1" and "Sub1" is calling "Sub3", and likewise ...


I need an output in an hierarchy saying parent->child->subchild...


Expected Output 1:
Folder1->Sub1->Sub3->Sub4
Folder1->Sub2
Folder2->Sub6
Folder2->Sub7->Sub8
Folder2->Sub7->Sub9


Expected Output 2:
In the 3rd column of excel against each row of Calling & Called columns ,Output should be as below(i.e, Parent|Child|...):
Folder1|Sub1
Folder1|Sub2
Folder1|Sub1|Sub3
Folder1|Sub1|Sub3|Sub4
Folder2|Sub6
Folder2|Sub7
Folder2|Sub7|Sub8
Folder2|Sub7|Sub9


Please help me out in this. Thanks
 
Hi Mike,

Apologies. Your code is working and it is perfectly satisfying my requirement :). Thanks a ton for helping me !!

I have 2500 rows of data. When I execute with this set of data, I am getting error on the line,
DataRange.Offset(0, 2).Resize(65536, 10).ClearContents
Please help. Thanks
 
Upvote 0
Hi Mike,
I changed the line to DataRange.Offset(0, 2).Resize(2500, 2).ClearContents.
For few data it ran and then it started throwing Error "Out Of Stack Space" on the line "For Each oneDescent In DescentStrings(oneKid)". :(
 
Upvote 0
Mike,

The hierarchy of parent child is many for few of the rows, hence stack memory is filling up. Please provide some workaround for this.thanks.
 
Upvote 0
When I get off work, I'll change DescentStrings to a non-recursive function. (Alternatly, the self recursion might be the source of the problem)
 
Upvote 0
It was those "parent its own child" cases that caused the issue.
Replace that version of DescentStrings with this one
Code:
Function DescentStrings(aParent As clsLink) As Object
    Dim Result As New Collection
    Dim oneKid As clsLink
    Dim oneName As String, oneDescent As Variant
    If aParent.Children.Count = 0 Then
        Result.Add Item:=aParent.Name
    Else
        For Each oneKid In aParent.Children
            If oneKid.Name = aParent.Name Then
                oneName = aParent.Name & ">*"
                On Error Resume Next
                Result.Add Item:=oneName, Key:=oneName
                On Error GoTo 0
            Else
            For Each oneDescent In DescentStrings(oneKid)
                oneName = aParent.Name & ">" & oneDescent
                On Error Resume Next
                Result.Add Item:=oneName, Key:=oneName
                On Error GoTo 0
            Next oneDescent
            End If
        Next oneKid
    End If
    Set DescentStrings = Result
End Function
 
Upvote 0
This version will handle recursive loops, as well as children with multiple parents.
Note the looping character that indicates the location to which a looping descent, loops back to.
Also, I think I've got the second output you want.

(along with clsLinks and clsLink)
Code:
' in normal module

Const Delimiter As String = " > "
Const LoopMarker As String = "~": Rem not wildcard character

Sub test()
    Dim allLinks As New clsLinks, oneLink As clsLink
    Dim DataRange As Range, outPutRange As Range
    Dim oneCell As Range
    Dim strOfDescent As String, arrDescendants As Variant, arrOut As Variant
    Dim i As Long
    
    With Sheet1.Range("A:A")
        Set DataRange = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    Set outPutRange = Range("F:F")
    
    Rem make Parents and children
    For Each oneCell In DataRange
        With allLinks.AddLink(CStr(oneCell.Value))
            .AddChild CStr(oneCell.Offset(0, 1).Value)
        End With
    Next oneCell
    
    Rem write all descent strings
    With outPutRange.EntireColumn
        .Resize(, 3).ClearContents
        For Each oneLink In allLinks.Item
            If Not oneLink.IsChild Then
                Call MakeAllDec(oneLink, "", .Cells)
            End If
        Next oneLink
        Set outPutRange = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    
    For Each oneCell In outPutRange
        strOfDescent = CStr(oneCell.Value)
        arrDescendants = Split(strOfDescent, Delimiter)
    
        For i = 1 To UBound(arrDescendants)
            arrOut = arrDescendants
            ReDim Preserve arrOut(0 To i)
            strOfDescent = Join(arrOut, Delimiter)
            
            If arrDescendants(i) <> LoopMarker Then
                strOfDescent = Replace(strOfDescent, LoopMarker, vbNullString, 1, 1)
            End If
            
            With oneCell.Offset(0, 1).EntireColumn
                If IsError(Application.Match(strOfDescent, .Cells, 0)) Then
                    With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                        .Value = strOfDescent
                    End With
                End If
            End With
        Next i
    Next oneCell
    With outPutRange.Offset(0, 1)
        With Range(.EntireColumn.Cells(Rows.Count, 1).End(xlUp), .Cells(1, 1))
            .Sort key1:=.Cells(1, 1)
        End With
    End With
End Sub

Function MakeAllDec(aParent As clsLink, Optional ByVal preString As String, Optional outCol As Range)
    Dim StringOfDescent As String
    Dim strOutputDescent As String
    Dim oneKid As clsLink

    StringOfDescent = preString & Delimiter & aParent.Name
    
    If aParent.Children.Count = 0 Then
        strOutputDescent = Mid(StringOfDescent, Len(Delimiter) + 1)
        outCol.Cells(65536, 1).End(xlUp).Offset(1, 0) = strOutputDescent
    Else
        For Each oneKid In aParent.Children
            If InStr(1, StringOfDescent & Delimiter, Delimiter & oneKid.Name & Delimiter, vbTextCompare) Then
                strOutputDescent = StringOfDescent & Delimiter & LoopMarker
                strOutputDescent = Replace(strOutputDescent, Delimiter & oneKid.Name & Delimiter, Delimiter & oneKid.Name & LoopMarker & Delimiter)
                strOutputDescent = Mid(strOutputDescent, Len(Delimiter) + 1)
                outCol.Cells(65536, 1).End(xlUp).Offset(1, 0) = strOutputDescent
            Else
                Call MakeAllDec(oneKid, StringOfDescent, outCol.EntireColumn)
            End If
        Next oneKid
    End If
End Function
 
Upvote 0
Hi Mike,

Thanks for the attempt which you are making :)
Second o/p is not kind of coming correct:
Folder1 > Sub1
Folder1 > Sub1 > Sub3
Folder1 > Sub1 > Sub3 > Sub4
Folder1 > Sub1 > Sub3 > Sub4 >
Folder1 > Sub2
Folder1 > Sub2 >
Folder2 > Sub6
Folder2 > Sub6 >
Folder2 > Sub7
Folder2 > Sub7 > Sub8
Folder2 > Sub7 > Sub8 >
Folder2 > Sub7 > Sub9
Folder2 > Sub7 > Sub9 >

Expected O/p for each row:

Folder1 > Sub1
Folder1 > Sub2
Folder1 > Sub1 > Sub3
Folder1 > Sub1 > Sub3 > Sub4
Folder2 > Sub6
Folder2 > Sub7
Folder2 > Sub7 > Sub8
Folder2 > Sub7 > Sub9

i.e,for each 2nd column row, hierarchy should list entire parent relation and should stop at each row.
 
Upvote 0
This should set things right
Code:
Sub test()
    Dim allLinks As New clsLinks, oneLink As clsLink
    Dim DataRange As Range, outPutRange As Range
    Dim oneCell As Range
    Dim strOfDescent As String, arrDescendants As Variant, arrOut As Variant
    Dim i As Long
    
    With Sheet1.Range("A:A")
        Set DataRange = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    Set outPutRange = Range("F:F")
    
    Rem make Parents and children
    For Each oneCell In DataRange
        With allLinks.AddLink(CStr(oneCell.Value))
            .AddChild CStr(oneCell.Offset(0, 1).Value)
        End With
    Next oneCell
    
    Rem write all descent strings
    With outPutRange.EntireColumn
        .Resize(, 3).ClearContents
        For Each oneLink In allLinks.Item
            If Not oneLink.IsChild Then
                Call MakeAllDec(oneLink, "", .Cells)
            End If
        Next oneLink
        Set outPutRange = Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
    End With
    
    For Each oneCell In outPutRange
        strOfDescent = CStr(oneCell.Value)
        arrDescendants = Split(strOfDescent, Delimiter)
    
        For i = 1 To UBound(arrDescendants)
            arrOut = arrDescendants
            ReDim Preserve arrOut(0 To i)
            strOfDescent = Join(arrOut, Delimiter)
            
            If arrDescendants(i) <> LoopMarker Then
                strOfDescent = Replace(strOfDescent, LoopMarker, vbNullString, 1, 1)
            End If
            
            With oneCell.Offset(0, 1).EntireColumn
                If IsError(Application.Match(strOfDescent, .Cells, 0)) Then
                    With .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)
                        .Value = strOfDescent
                        .Offset(0, 1).Value = i
                    End With
                End If
            End With
        Next i
    Next oneCell
    
    With outPutRange.Offset(0, 1)
        With Range(.EntireColumn.Cells(Rows.Count, 1).End(xlUp), .Cells(1, 1))
            With .Resize(.Rows.Count, 2)
            .Sort key1:=.Cells(1, 1), key2:=.Cells(1, 2)
            End With
            .Columns(2).ClearContents
        End With
    End With
End Sub
 
Upvote 0

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top