Tree / Level Structure "From & To" Input

Havings read an earlier thread "Setting up Tree Structure", Forum Guru, JBeaucaire came up with a briliant solution which is exactly what I need but I require to allow for more levels. I have had only limited experience and am finding it difficult to follow methodology (seems to use autofilter) so as to adapt it.

Essentially I want to input input data with "from" & "to" nodes and generate a level structure. A spreadsheet is attached which shows input and output format. The borders and cell colours are not essential in output sheet but would like to end up with a similar tree structure which can be prettied up manually as shown.

The numer of input rows could be upto 250 with upto 9 levels.

If it is too difficult no problems.

Mike

Give this a try on the sample data, then a larger data set.

Option Explicit

Sub TreeStructure()
'JBeaucaire  3/6/2010
'Create a flow tree from a two-column accountability table
Dim LR As Long, NR As Long, i As Long, Rws As Long
Dim TopRng As Range, TopR As Range, cell As Range
Dim wsTree As Worksheet, wsData As Worksheet
Application.ScreenUpdating = False

'Find top level value(s)
Set wsData = Sheets("Input")
    wsData.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsData.Range("M1"), Unique:=True
    wsData.Range("N2", wsData.Range("M" & Rows.Count).End(xlUp).Offset(0, 1)).FormulaR1C1 = "=IF(COUNTIF(C2,RC13)=0,1,"""")"
    
    Set TopRng = wsData.Columns("N:N").SpecialCells(xlCellTypeFormulas, 1).Offset(0, -1)
    LR = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Row
    
'Setup table
    Set wsTree = Sheets("LEVEL STRUCTURE")
    wsTree.Activate
    Cells.Clear
    NR = 3

'Parse each run from the top level
    For Each TopR In TopRng
        wsTree.Range("B" & NR) = TopR
        Set cell = Cells(NR, Columns.Count).End(xlToLeft)
    
        Do Until cell.Column = 1
            wsData.Range("A:A").AutoFilter Field:=1, Criteria1:=cell
            LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
            If LR > 1 Then
                Rws = wsData.Range("B2:B" & LR).SpecialCells(xlCellTypeVisible).Rows.Count
                cell.Offset(1, 1).Resize(Rws).EntireRow.Insert xlShiftDown
                wsData.Range("B2:B" & LR).SpecialCells(xlCellTypeVisible).Copy cell.Offset(1, 1)
                If Cells(Rows.Count, cell.Column + 1).End(xlUp).Address <> cell.Offset(1, 1).Address Then _
                    Range(cell.Offset(1, 1), cell.Offset(1, 1).End(xlDown)).Borders(xlEdgeLeft).Weight = xlThick
            End If
            
            NR = NR + 1
            Set cell = Cells(NR, Columns.Count).End(xlToLeft)
        Loop
    Next TopR

    Range("B1") = "LEVEL 1"
    Range("B1").AutoFill Destination:=wsTree.Range("B1:J1"), Type:=xlFillDefault
    Range("B1:J1").HorizontalAlignment = xlCenter
    With Range("B:T").SpecialCells(xlCellTypeConstants, 23)
        .Interior.ColorIndex = 5
        .Font.ColorIndex = 2
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    Range("B1:J1").Interior.ColorIndex = 53

wsData.AutoFilterMode = False
wsData.Range("M:N").ClearContents

Range("B3").Activate
Application.ScreenUpdating = True
End Sub

Well I'm glad it works for you.

And I'm intrigued. Can you share an example of how it highlighted errors? The only formatting I included was intended to match your desired coloring scheme. I'd love to see "helpful" side effects, hehe...

Hi Jerry, Unfortunately cleaned up data set using you macro. However, have included a number of typical errors in data set to highlight where errors can be picked up relatively easily. Refer to output that includes additional columns.
The one error that was not in my original data set and did send it into an infinite loop was if there was a "from-to" (A,C) that was same as a "from-to" (C,A).

Thanks again, Regards, Mike

PS realised that if you run macro then the checks are overwriten. Will move checks into separate sheet and use indirect/offset in future.