vba 在 Excel 中构建一个类似于数据表示的树？

Build a tree like representation of data in Excel?

提问by Michael Galos

I have a bunch of raw data in this fashion:

我有一堆这种方式的原始数据：

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

Which needs to be converted into a tree like fashion. This basically needs to end up in an excel spreadsheet. How can I convert the above data into the following:

需要将其转换为时尚之树。这基本上需要以excel电子表格结束。如何将上述数据转换为以下内容：

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

Is there any easy way to do this using only VBA?

有没有什么简单的方法可以只使用 VBA 来做到这一点？

回答by Christian Payne

I'm sure you can tidy this up, but this will work on the data set you've provided.

我相信您可以整理一下，但这将适用于您提供的数据集。

Before you start, you will need to define two Names (Insert / Name / Define). "Data" is the range of your dataset, "Destination" is the spot where you want the tree to go.

在开始之前，您需要定义两个名称（插入/名称/定义）。“数据”是数据集的范围，“目的地”是您希望树去的地方。

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

回答by Vincent Tang

I had to look up this solution today and I found it elsewhere, in case anyone is looking for this answer still

我今天不得不查找这个解决方案，我在其他地方找到了它，以防有人仍在寻找这个答案

Specify the sheet you want as "INPUT"

将您想要的工作表指定为“输入”

and the output sheet as "LEVEL STRUCTURE"

和输出表为“水平结构”

Form is in parent | child, so if your data is backwards just swap columns If its the top most node, put in rootas the name for parent.

形式在 中parent | child，因此如果您的数据向后，只需交换列 如果它是最顶部的节点，则root作为 的名称输入parent。

that way every cell in columns A,B have some value in it

这样 A、B 列中的每个单元格都有一些值

run excel vba

运行 excel vba

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

来源：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