Я начал и закончил ответ ниже прошлой ночью.В холодном свете дня требуется как минимум некоторое расширение.
Sheet2, исходные данные, до запуска макроса:
Sheet3, результат, послевыполняется макрос:
Основой метода является создание массивов, которые связывают каждого дочернего элемента с его родителем.Затем макрос следует по цепочке от каждого дочернего элемента до его предков, растущих строку: child, parent | child, grandparent | parent | child, ... После сортировки этот результат готов к сохранению.
С помощьюНапример, шаги 1 и 3 можно объединить, поскольку все имена и строки расположены в алфавитном порядке.Построение списка имен за один шаг и связывание их с другим делает простой макрос независимо от последовательности.Поразмыслив, я не уверен, что шаг 2, сортировка имен, необходим.Сортировка списков имен предков, шаг 5, необходима.Сортировка Sheet3 после вывода невозможна, поскольку может быть более трех уровней.
Я не уверен, что это считается элегантным решением, но оно довольно простое.
Я поместилисходные данные на листе Sheet2 и I выводятся на Sheet3.
Есть 7 этапов:
- Построить массив Child, содержащий каждое имя.
- Сортировать массив Child.Я предоставил простой вид, который подходит для демонстрации.Лучшие сортировки доступны в Интернете, если у вас достаточно имен, чтобы потребовать его.
- Построить массив Parent так, чтобы Parent (N) был индексом в Child для родительского объекта Child (N).
- Построить массив ParentName, следуя указателям в массиве Parent от дочернего к родительскому и бабушкин до ... При этом определите максимальное количество уровней.
- Сортируйте массив ParentName.
- Постройтестрока заголовка в выходном листе.
- Скопируйте ParentName на выходной лист.
Мне кажется, я включил достаточно комментариев, чтобы код был понятным.
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