vba 如何在excel中建立父子数据表？

how to build parent-child data table in excel?

提问by Pasi

I have 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 below like fashion. This basically needs to end up in an excel spreadsheet. How can I convert the above data into the following:

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

Levels

级别

1   |  2  | 3

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

回答by Tony Dallimore

I started and finished the answer below late last night. In the cold light of day it needs at least some expansion.

我昨晚深夜开始并完成了下面的答案。在寒冷的白天，它至少需要一些扩展。

Sheet2, source data, before the macro is run:

Sheet2，源数据，宏运行前：

Sheet3, result, after the macro is run:

Sheet3，结果，宏运行后：

The basis of the method is to create arrays that link each child to its parent. The macro then follows the chain from each child up its ancesters growing a string: child, parent|child, grandparent|parent|child, ... After sorting, this is the result ready for saving.

该方法的基础是创建将每个子项链接到其父项的数组。宏然后沿着从每个子级到其祖先的链，生成一个字符串：子级，父级|子级，祖父级|父级|子级，...排序后，这是准备保存的结果。

With the example data, Steps 1 and 3 could be combined because all the names and rows are in alphabetic order. Building the list of names in one step and linking them in another makes for a simple macro regardless of the sequence. On reflection, I am not sure if step 2, sorting the names, is necessary. Sorting the ancester name lists, step 5, is necessary. Sorting Sheet3 after output is not possible because there might be more than three levels.

对于示例数据，步骤 1 和 3 可以合并，因为所有名称和行都按字母顺序排列。在一个步骤中构建名称列表并在另一个步骤中将它们链接起来，可以形成一个简单的宏，而不管顺序如何。经过反思，我不确定第 2 步（对名称进行排序）是否有必要。排序祖先名单，步骤 5，是必要的。输出后排序 Sheet3 是不可能的，因为可能有三个以上的级别。

---

---

I am not sure if this counts as an elegant solution but its pretty simple.

我不确定这是否算是一个优雅的解决方案，但它非常简单。

I have placed the source data in worksheet Sheet2 and I output to Sheet3.

我已将源数据放在工作表 Sheet2 中并输出到 Sheet3。

There are 7 stages:

有7个阶段：

1. Build array Child containing every name.
2. Sort array Child. I have provided a simple sort which is adequate for a demonstration. Better sorts are available on the internet if you have enough names to require it.
3. Build array Parent such that Parent(N) is the index within Child of the parent of Child(N).
4. Build array ParentName by following the pointers in array Parent from child to parent to grandparent to ... While doing this, determine the maximum number of levels.
5. Sort array ParentName.
6. Build a header row in the output sheet.
7. Copy ParentName to the output sheet.

1. 构建包含每个名称的数组 Child。
2. 排序数组子项。我提供了一个简单的排序，足以进行演示。如果您有足够的名称来要求它，则 Internet 上可以提供更好的分类。
3. 构建数组 Parent，使得 Parent(N) 是 Child(N) 的父级的 Child 内的索引。
4. 通过遵循数组 Parent 中的指针从子级到父级到祖父级到...构建数组 ParentName 执行此操作时，确定最大级别数。
5. 排序数组 ParentName。
6. 在输出表中构建标题行。
7. 将 ParentName 复制到输出表。

I believe I have included enough comments for the code to be understandable.

我相信我已经包含了足够多的注释以使代码易于理解。

Option Explicit
Sub CreateParentChildSheet()

  Dim Child() As String
  Dim ChildCrnt As String
  Dim InxChildCrnt As Long
  Dim InxChildMax As Long
  Dim InxParentCrnt As Long
  Dim LevelCrnt As Long
  Dim LevelMax As Long
  Dim Parent() As Long
  Dim ParentName() As String
  Dim ParentNameCrnt As String
  Dim ParentSplit() As String
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Worksheets("Sheet2")
    RowLast = .Cells(Rows.Count, 1).End(xlUp).Row
    ' If row 1 contains column headings, if every child has one parent
    ' and the ultimate ancester is recorded as having a parent of "Root",
    ' there will be one child per row
    ReDim Child(1 To RowLast - 1)

    InxChildMax = 0
    For RowCrnt = 2 To RowLast
      ChildCrnt = .Cells(RowCrnt, 1).Value
      If LCase(ChildCrnt) <> "root" Then
        Call AddKeyToArray(Child, ChildCrnt, InxChildMax)
      End If
      ChildCrnt = .Cells(RowCrnt, 2).Value
      If LCase(ChildCrnt) <> "root" Then
        Call AddKeyToArray(Child, ChildCrnt, InxChildMax)
      End If
    Next

    ' If this is not true, one of the assumptions about the
    ' child-parent table is false
    Debug.Assert InxChildMax = UBound(Child)

    Call SimpleSort(Child)

    ' Child() now contains every child plus the root in
    ' ascending sequence.

    ' Record parent of each child
      ReDim Parent(1 To UBound(Child))
      For RowCrnt = 2 To RowLast
        If LCase(.Cells(RowCrnt, 1).Value) = "root" Then
          ' This child has no parent
          Parent(InxForKey(Child, .Cells(RowCrnt, 2).Value)) = 0
        Else
          ' Record parent for child
          Parent(InxForKey(Child, .Cells(RowCrnt, 2).Value)) = _
                           InxForKey(Child, .Cells(RowCrnt, 1).Value)
        End If
      Next

  End With

  ' Build parent chain for each child and store in ParentName
  ReDim ParentName(1 To UBound(Child))

  LevelMax = 1

  For InxChildCrnt = 1 To UBound(Child)
    ParentNameCrnt = Child(InxChildCrnt)
    InxParentCrnt = Parent(InxChildCrnt)
    LevelCrnt = 1
    Do While InxParentCrnt <> 0
      ParentNameCrnt = Child(InxParentCrnt) & "|" & ParentNameCrnt
      InxParentCrnt = Parent(InxParentCrnt)
      LevelCrnt = LevelCrnt + 1
    Loop
    ParentName(InxChildCrnt) = ParentNameCrnt
    If LevelCrnt > LevelMax Then
      LevelMax = LevelCrnt
    End If
  Next

  Call SimpleSort(ParentName)

  With Worksheets("Sheet3")
    For LevelCrnt = 1 To LevelMax
      .Cells(1, LevelCrnt) = "Level " & LevelCrnt
    Next
    ' Ignore entry 1 in ParentName() which is for the root
    For InxChildCrnt = 2 To UBound(Child)
      ParentSplit = Split(ParentName(InxChildCrnt), "|")
      For InxParentCrnt = 0 To UBound(ParentSplit)
        .Cells(InxChildCrnt, InxParentCrnt + 1).Value = _
                                                ParentSplit(InxParentCrnt)
      Next
    Next

  End With

End Sub

Sub AddKeyToArray(ByRef Tgt() As String, ByVal Key As String, _
                                                  ByRef InxTgtMax As Long)

  ' Add Key to Tgt if it is not already there.

  Dim InxTgtCrnt As Long

  For InxTgtCrnt = LBound(Tgt) To InxTgtMax
    If Tgt(InxTgtCrnt) = Key Then
      ' Key already in array
      Exit Sub
    End If
  Next
  ' If get here, Key has not been found
  InxTgtMax = InxTgtMax + 1
  If InxTgtMax <= UBound(Tgt) Then
    ' There is room for Key
    Tgt(InxTgtMax) = Key
  End If

End Sub

Function InxForKey(ByRef Tgt() As String, ByVal Key As String) As Long

  ' Return index entry for Key within Tgt

  Dim InxTgtCrnt As Long

  For InxTgtCrnt = LBound(Tgt) To UBound(Tgt)
    If Tgt(InxTgtCrnt) = Key Then
      InxForKey = InxTgtCrnt
      Exit Function
    End If
  Next

  Debug.Assert False        ' Error

End Function
Sub SimpleSort(ByRef Tgt() As String)

  ' On return, the entries in Tgt are in ascending order.

  ' This sort is adequate to demonstrate the creation of a parent-child table
  ' but much better sorts are available if you google for "vba sort array".

  Dim InxTgtCrnt As Long
  Dim TempStg As String

  InxTgtCrnt = LBound(Tgt) + 1
  Do While InxTgtCrnt <= UBound(Tgt)
    If Tgt(InxTgtCrnt - 1) > Tgt(InxTgtCrnt) Then
      ' The current entry belongs before the previous entry
      TempStg = Tgt(InxTgtCrnt - 1)
      Tgt(InxTgtCrnt - 1) = Tgt(InxTgtCrnt)
      Tgt(InxTgtCrnt) = TempStg
      ' Check the new previous enty against its previous entry if there is one.
      InxTgtCrnt = InxTgtCrnt - 1
      If InxTgtCrnt = LBound(Tgt) Then
        ' Prevous entry is start of array
        InxTgtCrnt = LBound(Tgt) + 1
      End If
    Else
      ' These entries in correct sequence
      InxTgtCrnt = InxTgtCrnt + 1
    End If
  Loop

End Sub

回答by PatricK

I have a simpler solution using TreeView object. If you don't mind the order of the nodes to be difference and using MSCOMCTL.OCX, please use below code.

我有一个使用TreeView object的更简单的解决方案。如果您不介意节点的顺序不同并使用MSCOMCTL.OCX，请使用以下代码。

Requires MSOCOMCTL.OCX to be registered.

需要注册 MSOCOMCTL.OCX。

Consider this data:

考虑这个数据：

Using a TreeView (adding to a UserForm for visualization, code not shown):

使用 TreeView（添加到用户窗体以进行可视化，代码未显示）：

Code to dump the tree data (normal module, use TreeToText):

转储树数据的代码（普通模块，使用TreeToText）：

Option Explicit

Private oTree As TreeView

Private Sub CreateTree()
    On Error Resume Next ' <-- To keep running even error occurred
    Dim oRng As Range, sParent As String, sChild As String

    Set oRng = ThisWorkbook.Worksheets("Sheet1").Range("A2") ' <-- Change here to match your Root cell
    Do Until IsEmpty(oRng)
        sParent = oRng.Value
        sChild = oRng.Offset(0, 1).Value
        If InStr(1, sParent, "root", vbTextCompare) = 1 Then
            oTree.Nodes.Add Key:=sChild, Text:=sChild
        Else
            oTree.Nodes.Add Relative:=oTree.Nodes(sParent).Index, Relationship:=tvwChild, Key:=sChild, Text:=sChild
        End If
        '--[ ERROR HANDLING HERE ]--
        ' Invalid (Repeating) Child will have the Row number appended
        If Err.Number = 0 Then
            Set oRng = oRng.Offset(1, 0) ' Move to Next Row
        Else
            oRng.Offset(0,1).Value = sChild & " (" & oRng.Row & ")"
            Err.Clear
        End If
    Loop
    Set oRng = Nothing
End Sub

Sub TreeToText()
    Dim oRng As Range, oNode As Node, sPath As String, oTmp As Variant

    ' Create Tree from Data
    Set oTree = New TreeView
    CreateTree
    ' Range to dump Tree Data
    Set oRng = ThisWorkbook.Worksheets("Sheet1").Range("D2") ' <-- Change here
    For Each oNode In oTree.Nodes
        sPath = oNode.FullPath
        If InStr(1, sPath, oTree.PathSeparator, vbTextCompare) > 0 Then
            oTmp = Split(sPath, oTree.PathSeparator)
            oRng.Resize(, UBound(oTmp) + 1).Value = oTmp
            Set oRng = oRng.Offset(1, 0)
        End If
    Next
    Set oRng = Nothing
    Set oTree = Nothing
End Sub

Output of code (hard code to D2):

代码输出（硬编码到 D2）：

If you have a very large data, you better off load the Range to memory first.

如果您有非常大的数据，最好先将 Range 加载到内存中。