如何在Excel中build立父子数据表？

我有这样的数据：

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

哪个需要转换成像时尚一样的下面。 这基本上需要最终在一个Excel电子表格。 如何将上述数据转换为以下内容：

水平

 1 | 2 | 3 AAA | BBB | AAA | BBB | EEE AAA | BBB | FFF AAA | CCC | AAA | CCC | GGG AAA | DDD | AAA | DDD | HHH 

Answer 1

我昨天晚上开始并完成了答案。 在一天的寒冷中，至less需要一些扩展。

Sheet2，源数据，在macros运行之前：

Sheet3，运行macros后的结果：

该方法的基础是创build将每个孩子链接到其父母的数组。 然后，macros从每个孩子的链上沿着一个string生成一个string：child，parent | child，grandparent | parent | child，…sorting后，这是准备好保存的结果。

对于示例数据，步骤1和步骤3可以组合，因为所有名称和行均按字母顺序排列。 在一个步骤中构build名称列表并将它们链接到另一个步骤中，无论顺序如何，都可以生成一个简单的macros。 经过反思，我不确定第二步是否需要sorting名称。 sorting附件名称列表，第5步是必要的。 输出后不能sortingSheet3，因为可能有三个以上的级别。

---

我不知道这是否是一个优雅的解决scheme，但它非常简单。

我已经将源数据放在工作表Sheet2中，然后输出到Sheet3。

有7个阶段：

1. 构build包含每个名称的数组
2. sorting数组Child。 我已经提供了一个适合示范的简单的sorting。 如果你有足够的名字需要，可以在网上find更好的分类。
3. 构build数组父项，使得父项（N）是子项（N）父项的子项中的索引。
4. 根据数组中的指针构build数组ParentName，从父对象到祖父对象…在执行此操作时，确定最大级别数。
5. sorting数组ParentName。
6. 在输出表中构build标题行。
7. 将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 

Answer 2

我有一个更简单的解决scheme，使用TreeView对象 。 如果您不介意节点顺序不同而使用MSCOMCTL.OCX ，请使用下面的代码。

需要注册MSOCOMCTL.OCX。

考虑这些数据：

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

转储树数据的代码（正常模块，使用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 

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

如果你有一个非常大的数据，你最好先把范围加载到内存。