Convert Parent-Child into Excel Hierarchy using VBA

[aston_007]

Hi experts!

I'm trying to traverse and convert a Parent|Child file into a separate hierarchy, with a header.
The 'depth' of the Parent|Child relationships is yet unknown, so the output could stretch to many columns on the right.
I have tried coding for just two input columns, with little success as it's very slow and restrictive.

Any help would be much appreciated. Thank you.

Input tab:

Parent	Child	Description
Europe	UK	United Kingdom
Europe	FR	France
Europe	ES	Spain
Europe	IT	Italy
Europe	DE	Germany
UK	LDN	London
UK	LDS	Leeds
UK	LIV	Liverpool
FR	PAR	Paris
FR	LYN	Lyon
FR	DIJ	Dijon
FR	CAL	Calais
ES	MAD	Madrid
ES	MAL	Malaga
ES	VAL	Valencia
LDN	RCH	Richmond
LDN	CHW	Chiswick
MAD	SAL	Salamanca
MAD	RET	Retiro

Output Tab:

Continent	Country	Country Desc	City	City Desc	Town	Town Desc
Europe
	UK	United Kingdom
			LDN	London
					RCH	Richmond
					CHW	Chiswick
			LDS	Leeds
			LIV	Liverpool
	FR	France
			PAR	Paris
			LYN	Lyon
			DIJ	Dijon
			CAL	Calais
	ES	Spain
			MAD	Madrid
					SAL	Salamanca
					RET	Retiro
			MAL	Malaga
			VAL	Valencia

 

[Eric W]

Consider:

Sub Hierarchy()
Dim InputCell As Range, OutputCell As Range, d As Variant
Dim t() As Variant, ts As Variant, TopLevel As String
Dim i As Long, r As Long, c As Long, l2 As String, Loc As Long

    Set InputCell = Sheets("Sheet1").Range("A2")
    Set OutputCell = Sheets("Sheet1").Range("F2")
    
    d = InputCell.Resize(InputCell.End(xlDown).Row - InputCell.Row + 1, 3).Value
    ReDim t(1 To UBound(d), 0 To 10)
    
    TopLevel = d(1, 1)
    For i = 1 To UBound(d)
        str1 = d(i, 2) & "|"
        l2 = d(i, 2)
        While l2 <> TopLevel
            With WorksheetFunction
                l2 = .XLookup(l2, .Index(d, 0, 2), .Index(d, 0, 1), 0)
            End With
            str1 = l2 & "|" & str1
        Wend
        c = 1
        While str1 <> ""
            Loc = InStr(str1, "|")
            t(i, c) = Left(str1, Loc - 1)
            str1 = Mid(str1, Loc + 1)
            c = c + 1
        Wend
        While c < 11
            t(i, c) = Chr(1)
            c = c + 1
        Wend
        t(i, 0) = d(i, 3)
    Next i
    
    ts = WorksheetFunction.Sort(t, Array(2, 3, 4, 5, 6, 7, 8, 9, 10, 11), Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1))
    Application.ScreenUpdating = False

    OutputCell = TopLevel
    For r = 1 To UBound(ts)
        For i = 2 To 10
            If ts(r, i) = Chr(1) Then Exit For
        Next i
        c = i - 3
        OutputCell.Offset(r, c * 2) = ts(r, c + 2)
        OutputCell.Offset(r, c * 2 + 1) = ts(r, 1)
    Next r

    Application.ScreenUpdating = True        
End Sub

This changes the A2 range to the F2 table:

Book2
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1	Parent	Child	Description
2	Europe	UK	United Kingdom			Europe
3	Europe	FR	France					DE	Germany
4	Europe	ES	Spain					ES	Spain
5	Europe	IT	Italy							MAD	Madrid
6	Europe	DE	Germany									RET	Retiro
7	UK	LDN	London									SAL	Salamanca
8	UK	LDS	Leeds							MAL	Malaga
9	UK	LIV	Liverpool							VAL	Valencia
10	FR	PAR	Paris					FR	France
11	FR	LYN	Lyon							CAL	Calais
12	FR	DIJ	Dijon							DIJ	Dijon
13	FR	CAL	Calais							LYN	Lyon
14	ES	MAD	Madrid							PAR	Paris
15	ES	MAL	Malaga					IT	Italy
16	ES	VAL	Valencia					UK	United Kingdom
17	LDN	RCH	Richmond							LDN	London
18	LDN	CHW	Chiswick									CHW	Chiswick
19	MAD	SAL	Salamanca									RCH	Richmond
20	MAD	RET	Retiro							LDS	Leeds
21										LIV	Liverpool
22
23
24
Sheet1

Numerous caveats for this:

1) The top left item (Europe) is considered to be the root.
2) Every code in column 2 must be unique. There can't be a Springfield in both England and France for example, unless it's something like SPRE and SPRF.
3) This routine will handle up to 10 levels of dependency. That's easily changed if you want, even to an arbitrary amount.
4) I wrote this with 2 Excel 365 functions (Sort and XMATCH) which aren't available in Excel 2013.

However, it should work for you. Let me know what you think.

 

[aston_007]

Hi Eric.

That's amazing! This is just what I needed.

Apologies for the late reply as it was getting 'stuck' half way through its operation. I realised that some of the child values are numbers, so I'll need to convert these numbers to text before running or better still, cater for these numbers within the VBA script.

Thanks again Eric.

Mark

 

[jimrward]

I might have a go with a possible recursive solution later once I get home to my pc

 

[JEC]

Here a solution with a treeview (in a userform)

This is the code:

Private Sub UserForm_Initialize()
 Dim dic As Object, ar, j As Long
 
 ar = Sheets(1).Cells(1).CurrentRegion
 Set dic = CreateObject("scripting.dictionary")
 
 For j = 2 To UBound(ar)
    If Not dic.Exists(ar(j, 1)) Then
       dic(ar(j, 1)) = Empty
       dic(ar(j, 2)) = Empty
       TreeView1.Nodes.Add , , ar(j, 1), ar(j, 1)
       TreeView1.Nodes.Add ar(j, 1), 4, ar(j, 2), ar(j, 2) & "-" & ar(j, 3)
    Else
       TreeView1.Nodes.Add ar(j, 1), 4, ar(j, 2), ar(j, 2) & "-" & ar(j, 3)
       dic(ar(j, 2)) = Empty
    End If
 Next
End Sub

 

[aston_007]

Here a solution with a treeview (in a userform)

This is the code:

Private Sub UserForm_Initialize()
 Dim dic As Object, ar, j As Long
 
 ar = Sheets(1).Cells(1).CurrentRegion
 Set dic = CreateObject("scripting.dictionary")
 
 For j = 2 To UBound(ar)
    If Not dic.Exists(ar(j, 1)) Then
       dic(ar(j, 1)) = Empty
       dic(ar(j, 2)) = Empty
       TreeView1.Nodes.Add , , ar(j, 1), ar(j, 1)
       TreeView1.Nodes.Add ar(j, 1), 4, ar(j, 2), ar(j, 2) & "-" & ar(j, 3)
    Else
       TreeView1.Nodes.Add ar(j, 1), 4, ar(j, 2), ar(j, 2) & "-" & ar(j, 3)
       dic(ar(j, 2)) = Empty
    End If
 Next
End Sub

View attachment 112185

That looks neat!

I'll need to scrub up on my control skills to test this out end to end. Thank you.

 

[shaowu459]

a formula solution for your reference:

结构转换小题-REDUCE双循环+递归.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L
1	Parent	Child	Description	234	Europe
2	Europe	UK	UnitedKingdom			DE	Germany
3	Europe	FR	France			ES	Spain
4	Europe	ES	Spain					MAD	Madrid
5	Europe	IT	Italy							RET	Retiro
6	Europe	DE	Germany							SAL	Salamanca
7	UK	LDN	London					MAL	Malaga
8	UK	LDS	Leeds					VAL	Valencia
9	UK	LIV	Liverpool			FR	France
10	FR	PAR	Paris					CAL	Calais
11	FR	LYN	Lyon					DIJ	Dijon
12	FR	DIJ	Dijon					LYN	Lyon
13	FR	CAL	Calais					PAR	Paris
14	ES	MAD	Madrid			IT	Italy
15	ES	MAL	Malaga			UK	UnitedKingdom
16	ES	VAL	Valencia					LDN	London
17	LDN	RCH	Richmond							CHW	Chiswick
18	LDN	CHW	Chiswick							RCH	Richmond
19	MAD	SAL	Salamanca					LDS	Leeds
20	MAD	RET	Retiro					LIV	Liverpool
21	Asia	China	Beijing		Asia
22	Asia	Japan	Tokyo			China	Beijing
23						Japan	Tokyo
24
递归 (2)

Cell Formulas
Range	Formula
D1	D1	=LEN(FORMULATEXT(E1))
E1:K23	E1	=LET(A,A2:A22,B,B2:C22,f,LAMBDA(f,m,DROP(REDUCE(0,SEQUENCE(ROWS(m)),LAMBDA(x,y,LET(u,INDEX(m,y,),s,SORT(FILTER(B,A=@TAKE(u,-2),0)),IFNA(VSTACK(x,IF(@s=0,u,HSTACK(u,VSTACK("",f(f,s))))),"")))),1)),f(f,UNIQUE(FILTER(A,COUNTIF(B,A)=0))))
Dynamic array formulas.