Text Functions‎ > ‎

Cascading Tree

                        Sample File:  TreeStructure3.xls
TASK:
"I have a two column list of personnel. Column B person reports to the person listed in Column A of the same row. From this two-column dataset, create a Cascading Tree from the top down, showing all persons each manager is in charge of."

INPUT SHEET

  A B
1 Leader In Charge of
2 123 234
3 123 235
4 234 456
5 456 567
6 567 678
7 678 789
8 789 880
9 789 882
10 880 990
11 882 991
12 991 1000
13 annie linus
14 ashley jie3jie
15 dave 123
16 jane philip
17 jane ah boi
18 jane annie
19 jane steven
20 jasmine parry
21 jason stephen

LEVEL STRUCTURE

 BCDEFGHIJKLMNOP
1LEVEL 1LEVEL 2LEVEL 3LEVEL 4LEVEL 5LEVEL 6LEVEL 7LEVEL 8LEVEL 9LEVEL 10LEVEL 11LEVEL 12LEVEL 13LEVEL 14LEVEL 15
2               
3jane              
4 philip             
5  ashley            
6   jie3jie           
7    ji2          
8     ji         
9  jason            
10   stephen           
11    jimmy ng          
12     dave         
13      123        
14       234       
15        456      
16         567     
17          678    
18           789   
19            880  
20             990 
21            882  
22             991 
23              1000
24       235       
25 ah boi             
26  ah gal            
27  ah lau            

                    

CODE

Option Explicit

Sub TreeStructure()
'JBeaucaire  3/6/2010, 10/25/2011
'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")
  'create a unique list of column A values in column M
    wsData.Range("A:A").AdvancedFilter Action:=xlFilterCopy, _
         CopyToRange:=wsData.Range("M1"), Unique:=True

 
  'Find the ONE value in column M that reports to no one, the person at the top
    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)
  'last row of persons listed in data table
    LR = wsData.Range("A" & wsData.Rows.Count).End(xlUp).Row
   
'Setup table
    Set wsTree = Sheets("LEVEL STRUCTURE")
    With wsTree
        .Cells.Clear    'clear prior output
        NR = 3          'next row to start entering names

'Parse each run from the top level
    For Each TopR In TopRng         'loop through each unique column A name
        .Range("B" & NR) = TopR
        Set cell = .Cells(NR, .Columns.Count).End(xlToLeft)
   
        Do Until cell.Column = 1
          'filter data to show current leader only
            wsData.Range("A:A").AutoFilter Field:=1, Criteria1:=cell
        'see how many rows this person has in the table
            LR = wsData.Range("A" & Rows.Count).End(xlUp).Row
            If LR > 1 Then
              'count how many people report to this person
                Rws = Application.WorksheetFunction.Subtotal(103, wsData.Range("B:B")) - 1
              'insert that many blank rows below their name and insert the names
                cell.Offset(1, 1).Resize(Rws).EntireRow.Insert xlShiftDown
                wsData.Range("B2:B" & LR).Copy cell.Offset(1, 1)
              'add a left border if this is the start of a new "group"
                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     'increment to the next row to enter the next top leader name
            Set cell = .Cells(NR, .Columns.Count).End(xlToLeft)
        Loop
    Next TopR

  'find the last used column
    i = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), _
        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
  'format the used data range
    With Union(.Range(.[B1], .Cells(1, i)), .Range("B:BB").SpecialCells(xlCellTypeConstants, 23))
        .Interior.ColorIndex = 5
        .Font.ColorIndex = 2
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .Range("B1").Interior.ColorIndex = 53
    .Range("B1").Value = "LEVEL 1"
    .Range("B1").AutoFill Destination:=.Range("B1", .Cells(1, i)), Type:=xlFillDefault
End With

wsData.AutoFilterMode = False
wsData.Range("M:N").ClearContents
wsTree.Activate
Application.ScreenUpdating = True
End Sub



Nothing says "thanks" like a steak dinner!
PayPal - The safer, easier way to pay online!

Comments