Question

我有这种方式的数据：

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

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

运行宏之前的Sheet2，源数据：

Sheet2, source data, before the macro is run

运行宏后的Sheet3，结果：

Sheet3, result, after the macro is run

该方法的基础是创建将每个子项链接到其父项的数组。宏然后跟踪每个孩子的链，其祖先生长一个字符串：child，parent | child，grandparent | parent | child，...排序后，这就是准备保存的结果。

使用示例数据，可以组合步骤1和3，因为所有名称和行都按字母顺序排列。在一个步骤中构建名称列表并将它们链接到另一个步骤中会产生一个简单的宏，而不管序列如何。经过反思，我不确定是否需要对名称进行排序。必须对步骤5中的祖先名称列表进行排序。输出后无法对Sheet3进行排序，因为可能有三个以上的级别。

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

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

共有7个阶段：

构建包含每个名称的子数组。
排序数组Child。我提供了一个适合演示的简单类型。如果您有足够的名称可以在互联网上提供更好的排序。
构建数组Parent，使Parent（N）成为Child（N）父项的Child内的索引。
按照数组中的指针构建数组ParentName从父级到父级到祖父级的父级到...执行此操作时，确定最大级别数。
排序数组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

Answer 2

我使用TreeView object有一个更简单的解决方案。如果您不介意节点的顺序不同并使用 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）：

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

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

2 个答案: