我昨晚深夜开始并完成了下面的答案。在寒冷的白天，它至少需要一些扩展。
Sheet2，源数据，宏运行前：
Sheet3，结果，宏运行后：
该方法的基础是创建将每个子项链接到其父项的数组。然后，宏从每个孩子开始沿着其祖先的链向上生长一个字符串：孩子，父母|孩子，祖父母|父母|孩子，...排序后，这是可以保存的结果。
对于示例数据，步骤 1 和 3 可以合并，因为所有名称和行都按字母顺序排列。在一个步骤中构建名称列表并将它们链接到另一个步骤中可以生成一个简单的宏，而不管顺序如何。经过反思，我不确定是否有必要进行第 2 步（对名称进行排序）。第 5 步，对祖先姓名列表进行排序是必要的。输出后无法对 Sheet3 进行排序，因为可能超过三个级别。
我不确定这是否算作一个优雅的解决方案，但它非常简单。
我已将源数据放入工作表 Sheet2 并输出到 Sheet3。
有7个阶段：
- 构建包含每个名称的子数组。
- 排序数组子项。我提供了一个简单的排序，足以进行演示。如果您有足够的名字来要求它，可以在 Internet 上找到更好的分类。
- 构建数组 Parent 使得 Parent(N) 是 Child(N) 的父级的 Child 内的索引。
- 按照数组 Parent 中的指针从子级到父级到祖父级构建数组 ParentName... 在执行此操作时，确定最大级别数。
- 对数组 ParentName 进行排序。
- 在输出表中构建标题行。
- 将 ParentName 复制到输出表。
我相信我已经包含了足够多的 cmets 以使代码易于理解。
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