Tạo một cây giống như biểu diễn dữ liệu trong Excel?

Question

tôi có một loạt các dữ liệu thô trong thời trang này:

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

nào cần phải được chuyển đổi thành một cây như thời trang. Điều này về cơ bản cần phải kết thúc trong một bảng tính excel. Làm thế nào tôi có thể chuyển đổi các dữ liệu trên như sau:

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

Có cách nào dễ dàng để làm điều này chỉ sử dụng VBA?

Answer 1

Tôi chắc chắn bạn có thể ngăn chặn điều này, nhưng điều này sẽ hoạt động trên tập dữ liệu bạn đã cung cấp.

Trước khi bắt đầu, bạn sẽ cần xác định hai Tên (Chèn/Tên/Xác định). "Dữ liệu" là phạm vi của tập dữ liệu của bạn, "Đích" là vị trí bạn muốn cây di chuyển.

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

Tôi phải bất lực nhìn lên giải pháp này ngày hôm nay và tôi thấy nó ở nơi khác, trong trường hợp bất cứ ai đang tìm kiếm câu trả lời này vẫn

Xác định sheet mà bạn muốn là "INPUT"

và đầu ra trang tính là "CẤU TRÚC CẤP"

Biểu mẫu ở parent | child, vì vậy nếu dữ liệu của bạn là ngược lại, chỉ cần hoán đổi cột Nếu nút trên cùng của nó là root làm tên cho parent.

cách mà mỗi tế bào trong các cột A, B có một số giá trị trong nó

chạy Excel VBA

NGUỒN: 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