Excel'de verilerin temsili gibi bir ağaç oluşturun?

Question

Bu modada bir sürü ham veri var:

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

Hangi moda gibi bir ağaca dönüştürülmelidir. Bu temelde bir excel elektronik tablosunda bitmek zorunda. Yukarıdaki verileri aşağıdakilere nasıl dönüştürebilirim:

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

Bunu yalnızca VBA kullanarak yapmak için herhangi bir kolay yol var mı?

Answer 1

Bundan emin olabilirsiniz, ancak bu sağladığınız veri kümesi üzerinde çalışacaktır.

Başlamadan önce, iki Ad tanımlamanız gerekir (Ekle/Ad/Tanımla). "Veri" veri kümenizin aralığıdır, "Hedef" ağacın gitmesini istediğiniz noktadır.

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

Bugün bu çözümü aramak zorunda kaldı ve ben hala

siz "INPUT"

ve çıktı olarak istediğiniz sayfayı belirtin durumda herkes bu cevap arıyor, başka bir yerde buldum "SEVİYE YAPISI"

Formu olarak sac parent | child olduğunu, bu nedenle veri ise geriye sadece sütunları takas olursa parent adı olarak root koymak onun en üst düğüm. 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 

: sütunlarda her hücre, A, B, bazı değere sahip

bu şekilde o

vadede VBA

SOURCE excel