¿Cree un árbol como representación de datos en Excel?

Question

que tienen un montón de datos en bruto de esta manera:

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

que necesita ser convertida en un árbol como la moda. Esto básicamente tiene que terminar en una hoja de cálculo de Excel. ¿Cómo puedo convertir los datos anteriores en lo siguiente:

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

¿Hay alguna forma fácil de hacer esto utilizando sólo VBA?

Answer 1

Estoy seguro de que puede arreglar esto, pero esto funcionará en el conjunto de datos que ha proporcionado.

Antes de comenzar, tendrá que definir dos nombres (Insertar/Nombre/Definir). "Datos" es el rango de su conjunto de datos, "Destino" es el lugar donde desea que vaya el árbol.

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

tuve que buscar esta solución hoy y lo encontré en otro lugar, en caso de que alguien está buscando esta respuesta todavía

Especificar la hoja que desea como "Entrada"

y la salida de situación como "estructura de nivel"

formulario está en parent | child, por lo que si sus datos están al revés simplemente intercambiar columnas Si su más nodo superior, puesto en root como el nombre para parent.

de esa manera todas las células en las columnas A, B tienen algún valor en ella

ejecutar Excel VBA

FUENTE: 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