Extensive Tree Structure

[jomili]

In the thread located here http://www.excelforum.com/excel-prog...ml#post2310968 I asked for a macro that would resolve the tree structure of an organization, showing who reports to who all the way down the chain.

The macro developed worked well for the sample data, and went 4 levels into the structure, providing output like this:

Big boss →Midlevel1 → Midlevel2 →Caseworker

However, it couldn't cope with the full data, which has 8 or more levels of management, such as

Big boss →Little boss →Executive1→Executive2→Midlevel1 → Midlevel2 →Caseworker→Assistant Caseworker

The attached spreadsheet has the source data on Sheet 1, and on Sheet 2 a representation of what the output should look like. Any help I can get on getting to the desired output would be greatly appreciated.

[mrice]

Try this macro

Sub Main()
Tree
Rearrange
End Sub


Sub Tree()
Dim FoundBoss As Boolean
Sheets(1).Activate
Sheets(2).Cells.Clear
For N = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    Cells(N, 1).Select
    FoundBoss = True
    Sheets(2).Cells(N, 12) = Cells(N, 1)
    Sheets(2).Cells(N, 11) = Cells(N, 3)
    CurrentSearch = Cells(N, 3)
    Do While FoundBoss = True
        FoundBoss = False
        If Application.CountIf(Columns(1), CurrentSearch) > 0 Then
            CurrentSearch = Columns(1).Find(CurrentSearch, , xlValues, xlWhole).Offset(0, 2)
            FoundBoss = True
            Sheets(2).Cells(N, 1).End(xlToRight).Offset(0, -1) = CurrentSearch
        End If
    Loop
Next N

End Sub


Sub Rearrange()
Sheets(2).Activate
For N = 2 To Cells(Rows.Count, 12).End(xlUp).Row
    Range(Cells(N, 1), Cells(N, 1).End(xlToRight)).Delete Shift:=xlToLeft
Next N
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
For M = 1 To Cells(2, 1).CurrentRegion.Columns.Count
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range(Cells(2, M), Cells(LastRow, M)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Next M
With ActiveWorkbook.Worksheets("Sheet2").Sort
    .SetRange Cells(2, 1).CurrentRegion
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
For M = 1 To Cells(2, 1).CurrentRegion.Columns.Count
    For X = LastRow To 3 Step -1
        If Cells(X, M) = Cells(X - 1, M) Then Cells(X, M).Clear
    Next X
Next M
End Sub

It's not very efficient but it should get there in the end.

[shg]

The attached formats the output a little differently, but accommodates arbitrary depth. It does 10K names in about 3s.

[jomili]

Mrice,
I'm trying your macro now. It's been running for 5 minutes, and it's up to line 3500, so I understand what you meant by "not very efficient". But I look forward to the results.

SHG,
Some days the network here allows me to open or save zipped files from the forum, some days it doesn't. Today it doesn't. Can I get you to post just the macro?

Thanks to both of you for your help on this!

[jomili]

Martin,

The macro bombed at this line:

ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear

with the error message

Run-Time Error "438":
Object doesn't support this property or method.

[romperstomper]

The Sort object does not exist prior to Excel 2007, hence the error.