Vba 在Excel中构建数据的树状表示？

我有一堆这样的原始数据：

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

这需要转换成一种树状的时尚。 这基本上需要在excel电子表格中结束。 如何将上述数据转换为以下内容：

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

---

有什么简单的方法可以只用VBA来完成吗？

我相信您可以整理一下，但这会对您提供的数据集起作用

开始之前，需要定义两个名称（Insert/Name/define）。“数据”是数据集的范围，“目的地”是您希望树到达的位置

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

---

我今天不得不查找这个解决方案，我在别处找到了它，以防有人还在寻找这个答案

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

输出表为“水平结构”

表单位于

parent | child

中，因此如果您的数据是向后的，则只需交换列（如果它是最顶端的节点），将

根节点作为
父节点的名称

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

运行excelvba

资料来源：

选项显式
子树结构（）
'JBeaucaire 3/6/2010、10/25/2011
'从两列责任表创建流树
变暗LR为长，NR为长，i为长，Rws为长
调光TopRng作为范围、TopR作为范围、单元格作为范围
将wsTree设置为工作表，将wsData设置为工作表
Application.ScreenUpdating=False
'查找顶级值（个）
设置wsData=工作表（“输入”）
'在M列中创建a列值的唯一列表
wsData.Range（“A:A”）.AdvancedFilter操作：=xlFilterCopy_
CopyToRange:=wsData.Range（“M1”），唯一：=True
'在M列中找到一个不向任何人报告的值，即顶部的人
wsData.Range（“N2”，wsData.Range（“M”和Rows.Count）.End（xlUp）_
.Offset（0，1））.FormulaR1C1=“=IF（COUNTIF（C2，RC13）=0,1，”“””
设置TopRng=wsData.Columns（“N:N”）.SpecialCells（xlCellTypeFormulas，1）.偏移量（0，-1）
'数据表中列出的最后一行人员
LR=wsData.Range（“A”&wsData.Rows.Count）.End（xlUp）.Row
'设置表
设置wsTree=图纸（“水平结构”）
带wsTree
.Cells.Clear“清除先前输出
NR=3'下一行开始输入名称
'从顶层解析每个运行
对于TopRng中的每个TopR，通过每个唯一列循环一个名称
.范围（“B”和编号）=顶部
设置单元格=.Cells（NR，.Columns.Count）.End（xlToLeft）
直到cell.Column=1为止
'筛选数据以仅显示当前引线
wsData.Range（“A:A”）。自动筛选字段：=1，准则1:=cell
'查看此人在表中有多少行
LR=wsData.Range（“A”&Rows.Count）.End（xlUp）.Row
如果LR>1，则
'计算有多少人向此人报告
Rws=Application.WorksheetFunction.Subtotal（103，wsData.Range（“B:B”））-1
'在其名称下面插入许多空白行，然后插入名称
cell.Offset（1，1）.Resize（Rws）.EntireRow.Insert xlShiftDown
wsData.Range（“B2:B”和LR）.Copy cell.Offset（1，1）
'如果这是新“组”的开始，请添加左边框'
If.Cells（.Rows.Count，cell.Column+1）.End（xlUp）.Address_
单元格。偏移量（1，1）。然后是地址_
.范围（单元格偏移量（1,1）、单元格偏移量（1,1）.结束（xlDown））_
.边框（左）。重量=xl厚
如果结束
NR=NR+1'增加到下一行以输入下一个顶部引线名称
设置单元格=.Cells（NR，.Columns.Count）.End（xlToLeft）
环
下一个TopR
'查找最后使用的列
i=.Cells.Find（“*”，.Cells（.Rows.Count，.Columns.Count）_
SearchOrder:=xlByColumns，SearchDirection:=xlPrevious）.Column
'格式化使用的数据范围
带并集（.Range（[B1]，.Cells（1，i）），.Range（“B:BB”）。特殊单元格（xlcelltypectants，23））
.Interior.ColorIndex=5
.Font.ColorIndex=2
.Font.Bold=True
.HorizontalAlignment=xlCenter
以
.范围（“B1”）.内饰.ColorIndex=53
.Range（“B1”）.Value=“级别1”
.Range（“B1”）。自动填充目标：=.Range（“B1”），.Cells（1，i）），类型：=xlFillDefault
以
wsData.AutoFilterMode=False
wsData.Range（“M:N”）.ClearContents
wsTree.激活
Application.ScreenUpdating=True
端接头

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