Building a hierarchy

Hi,

I must build a hierarchy from the excel sheet shown below.

ParentChildChildNameChildren-1001GroupYes10011002USA OfficeYes10011003Argentina OfficeYes10011004EuropeYes10041005UK OfficeYes10041006Spain OfficeYes10061007MadridYes10011008Group ManagementNo10021009Sales USANo10031010Sales ArgNo10011011SubsidiariesNo10021012Back-office USANo10031013Back-office ArgNo10051014Back-office UKNo10071015Back-office SpainNo10051016Sales UKNo10071017Sales SpainNo

The aim is to show the hierarchy as you can see below.

Level 1Name 1Level 2Name 2Level 3Name 3Level 4Name 4Level 5Name 5OrgNoOrganisation1001Group







1008Group Management1001Group1002USA Office





1009Sales USA1001Group1003Argentina Office





1010Sales Arg1001Group







1011Subsidiaries1001Group1002USA Office





1012Back-office USA1001Group1003Argentina Office





1013Back-office Arg1001Group1004Europe1005UK Office



1014Back-office UK1001Group1004Europe1006Spain Office1007Madrid

1015Back-office Spain1001Group1004Europe1005UK Office



1016Sales UK1001Group1004Europe1006Spain Office1007Madrid

1017Sales Spain
I have tried different VBA solution and I think that using scripting dictionary could be a solution. However what should be the logical approach in solving this problem? I have tried other solution in VBA, but as there are 30.000 organisational units and the number of levels can be 15, the generation has been too slow and it has never finished. An approach could be:

Code:

---

sub_generate()

ParentCol = 1
ChildCol = 2
ChildNameCol = 3
Children = 4
Set first = CreateObject("Scripting.Dictionary")
Set Second2 = CreateObject("Scripting.Dictionary")

' child parent dictionary
For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
    If IsNumeric(Cells(i, ChildCol)) Then
    first.Add Val(Cells(i, ChildCol)), Cells(i, ParentCol)
    End If
Next
'child and its name dictionary
For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
    If IsNumeric(Cells(i, ChildCol)) Then
    Second2.Add Val(Cells(i, ChildCol)), Cells(i, ChildNameCol)
    End If
Next
For i = 2 To Cells.SpecialCells(xlCellTypeLastCell).Row
If Cells(i, Children) = "No" Then
'... what next
End If
Next
End Sub

---

Could you please help :whistle:

The output should be like

Input

Apu and Input are identical. Can you put all grids on one sheet with further explanation?