Convert Levels file into Parent-Child format

[aston_007]

Hello Experts.

Hoping that you will be able to assist.

I am needing to convert the following file format that has a levels hierarchy into a Parent/Child format.
The file can have up to 8 levels. It can also be 'ragged' in that not all levels to the right will have values as per the example below:

The conversion would result in a 4 column, Parent | Child output as below:

It would be useful if the Levels could be output sequentially so that all the parents are listed first with the last levels at the end.
Hope I've described that effectively!

Thanks very much all.

Mark

 

[kevin9999]

Hi Mark, Welcome to the board!

Here's just one possible way. Try it out on a copy of your data. Change the source & destination sheets to suit.

Option Explicit
Sub Parent_Child()
    Application.ScreenUpdating = False
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")  '<~~ Change to actual source sheet name
    Set ws2 = Worksheets("Sheet2")  '<~~ Change to actual destination shet name
    
    Dim LCol As Long, LRow As Long, lrS As Long, totR As Long
    LCol = ws1.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    lrS = ws1.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    
    'Fill the input array
    Dim arrIn, nRng As Long, i As Long, j As Long
    nRng = LCol / 2
    ReDim arrIn(1 To nRng)
    With ws1
        j = 1
        For i = 1 To nRng
            LRow = ws1.Range(ws1.Cells(1, j + 1), ws1.Cells(lrS, j + 1)).Find("*", , xlFormulas, , 1, 2).Row
            arrIn(i) = ws1.Cells(2, j).Resize(LRow, 4)
            totR = totR + UBound(arrIn(i), 1)
            j = j + 2
        Next i
    End With
    
    'Fill the output array
    Dim arr, r As Long, rw As Long, col As Long
    ReDim arrOut(1 To totR, 1 To 4)
    r = 1
    For i = 1 To nRng
        arr = arrIn(i)
        For rw = 1 To UBound(arr, 1)
            If arr(rw, 3) <> "" Then
                For col = 1 To UBound(arr, 2)
                arrOut(r, col) = arr(rw, col)
                Next col
                r = r + 1
            End If
        Next rw
    Next i
    
    'Put the result onto sheet 2
    With ws2
        .Range("A1").Resize(1, 4).Value2 = Array("Parent Code", "Parent Name", "Child Code", "Child Name")
        .Range("A2").Resize(totR, 4).Value2 = arrOut
        .Range("A:D").RemoveDuplicates Columns:=Array(1, 2, 3, 4)
        .Range("A1:D1").EntireColumn.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Sheet1:

Parent Child.xlsm
	A	B	C	D	E	F	G	H	I	J
1	L1 CODE	L1 NAME	L2 CODE	L2 NAME	L3 CODE	L3 NAME	L4 CODE	L4 NAME	L5 CODE	L5 NAME
2	GLOBAL	Global Tot	UK	United Kingdom	LON	London	LONN	North London	TOTN	Tottenham
3	GLOBAL	Global Tot	UK	United Kingdom	LON	London	LONS	South London	CHEA	Chelsea
4	GLOBAL	Global Tot	UK	United Kingdom	MAN	Manchester	MANS	South Manchester
5	GLOBAL	Global Tot	DE	Germany	BER	Berlin	BERS	South Berlin
6	GLOBAL	Global Tot	DE	Germany	HAN	Hanover	HANC	Central Hanover
Sheet1

Sheet2 after running the code:

Parent Child.xlsm
	A	B	C	D
1	Parent Code	Parent Name	Child Code	Child Name
2	GLOBAL	Global Tot	UK	United Kingdom
3	GLOBAL	Global Tot	DE	Germany
4	UK	United Kingdom	LON	London
5	UK	United Kingdom	MAN	Manchester
6	DE	Germany	BER	Berlin
7	DE	Germany	HAN	Hanover
8	LON	London	LONN	North London
9	LON	London	LONS	South London
10	MAN	Manchester	MANS	South Manchester
11	BER	Berlin	BERS	South Berlin
12	HAN	Hanover	HANC	Central Hanover
13	LONN	North London	TOTN	Tottenham
14	LONS	South London	CHEA	Chelsea
Sheet2

 

[aston_007]

Hi Kevin.

Thanks for replying so quickly. The code that you have offered as worked amazingly well!
I've run it against 8 levels and 30k+ lines and processed it so quickly.

Many thanks!

Mark

 

[kevin9999]

Happy to help Mark, and thanks for the feedback