Costruisci un albero come la rappresentazione dei dati in Excel?

Question

Ho un sacco di dati grezzi in questo modo:

Parent | Data 
--------------- 
Root | AAA 
AAA  | BBB 
AAA  | CCC 
AAA  | DDD 
BBB  | EEE 
BBB  | FFF 
CCC  | GGG 
DDD  | HHH 

che deve essere convertito in un albero come la moda. Questo in pratica deve finire in un foglio di calcolo Excel. Come posso convertire i dati di cui sopra nelle seguenti:

AAA |  | 
    | BBB | 
    |  | EEE 
    |  | FFF 
    | CCC | 
    |  | GGG 
    | DDD | 
    |  | HHH 

Esiste un modo semplice per farlo utilizzando solo VBA?

Answer 1

Sono sicuro che è possibile riordinare questo, ma questo funzionerà sul set di dati che hai fornito.

Prima di iniziare, è necessario definire due nomi (Inserisci/Nome/Definisci). "Dati" è l'intervallo del set di dati, "Destinazione" è il punto in cui si desidera che l'albero vada.

Sub MakeTree() 

    Dim r As Integer 
    ' Iterate through the range, looking for the Root 
    For r = 1 To Range("Data").Rows.Count 
     If Range("Data").Cells(r, 1) = "Root" Then 
      DrawNode Range("Data").Cells(r, 2), 0, 0 
     End If 
    Next 

End Sub 

Sub DrawNode(ByRef header As String, ByRef row As Integer, ByRef depth As Integer) 
'The DrawNode routine draws the current node, and all child nodes. 
' First we draw the header text: 
    Cells(Range("Destination").row + row, Range("Destination").Column + depth) = header 

    Dim r As Integer 
    'Then loop through, looking for instances of that text 
    For r = 1 To Range("Data").Rows.Count 
     If Range("Data").Cells(r, 1) = header Then 
     'Bang! We've found one! Then call itself to see if there are any child nodes 
      row = row + 1 
      DrawNode Range("Data").Cells(r, 2), row, depth + 1 
     End If 
    Next 
End Sub 

Answer 2

ho dovuto cercare questa soluzione oggi e l'ho trovato altrove, nel caso qualcuno è alla ricerca di questa risposta ancora

Specificare il foglio che si desidera come "INPUT"

e l'uscita patrimoniale "livello della struttura"

la forma è in parent | child, quindi se i vostri dati sono al contrario solo scambiare le colonne Se la sua più nodo superiore, messo in root come nome per parent.

questo modo ogni cellula nelle colonne A, B ha un valore in esso

eseguire Excel vba

FONTE: https://sites.google.com/a/madrocketscientist.com/jerrybeaucaires-excelassistant/text-functions/cascading-tree

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