Question

我有下表，需要帮助缩进父子关系。根节点从0开始，可以遍历1000个以上的级别以及子关系。

我如何在VBA中实现这一目标？

CPackName      CPackID      PPackID      PName      ParentID      PDATA 
Artifacts      1            1            AC         0             297
Template       1            1            AC         0             281
WA             1            1            AC         0             361
Alisha         361          361          WA         1             611 
Damian         361          361          WA         1             480
ABC            297          297          Artifacts  1             
DEF            297          297          Artifacts  1

我想在下面的列中显示这个。

enter image description here

Answer 1

以下Excel-VBA模块适合我。

Option Explicit

Type Tree_Node          ' note: and IDX of zero means that it does not exist.
    Idx As Long         'The array index of the original source record
    ParentIdx As Long   'The array index of the parent of this node
    Depth As Long       'The number of parent nodes above this node
    OutRow As Long      'The row offset this node should appear at
    Flink As Long       'next sibling of this node
    ChildCount As Long  'number of children found so far
    HeadIdx As Long     'First child node of this parent-node
    TailIdx As Long     'Last child node of this parent node
End Type
Private nod() As Tree_Node

Private maxDepth As Long

' Formats Record/Pack data into indented records.
'
'Parameters:
'   InputRange      - The source range that contains the record/pack data.
'                    (should NOT include the column headers)
'   FirstOutputCell - The top-left cell that the output data will be written to.
'                    All cells below or to the right of this may be overwritten.
'
Sub OutputIndentedRecords(InputRange As Range, FirstOutputCell As Range)
    ' Get all of the input data into a variant array
    Dim src As Variant
    src = InputRange
    Dim srcRows As Long
    srcRows = UBound(src, 1)
    ' source range column offsets
    Const CPackName = 1
    Const PPackID = 3
    Const PDATA = 6

    Dim PDataIdxs As New Collection 'collection to index the PDATA values
    ReDim nod(srcRows)  'array to hold the Tree Nodes representing each record

    '   make the zero entry the ultimate root, with no parent
    nod(0).ParentIdx = -1
    PDataIdxs.Add 0, "1"

    '   For each record in the source range, make a Tree_Node to represent it
    '(NOTE: This algorithm assumes that the parent always appears before its children
    '       in the source range.)
    Dim i As Long, j As Long
    For i = 1 To srcRows
        'is there a record here?
        If src(i, CPackName) <> "" Then
            ' Yes, so fill in the tree node
            With nod(i)

                .Idx = i
                ' Get the parent index
                .ParentIdx = PDataIdxs(CStr(src(i, PPackID)))
                ' add this node to the Parents child list
                With nod(.ParentIdx)
                    If .TailIdx <> 0 Then       'if theres already a child
                        nod(.TailIdx).Flink = i 'point it to us
                    Else                        'otherwise
                        .HeadIdx = i            'we are the head of the child list
                    End If
                    .TailIdx = i                'we are the new tail
                    .ChildCount = .ChildCount + 1
                End With

                ' Is it a potential Parent?
                If src(i, PDATA) <> "" Then
                    'yes, so flag it and index its PDATA value
                    PDataIdxs.Add i, CStr(src(i, PDATA))
                End If

            End With
        End If
    Next i

    ' Traverse the Tree structure, filling in Depth and Output row number
    Dim curRow As Long
    curRow = 1
    maxDepth = 0

    TraverseTreeDepthFirst 0, 1, curRow

    ' Make an output array and fill it in
    Dim out() As Variant
    ReDim out(curRow - 2, maxDepth - 2)
    For i = 1 To srcRows
        With nod(i)
            out(.OutRow - 2, .Depth - 2) = src(.Idx, CPackName)
        End With
    Next i

    'Make an output range to hold the array
    Dim wsOut As Worksheet, rngOut As Range
    Set wsOut = FirstOutputCell.Worksheet
    Set rngOut = wsOut.Range(FirstOutputCell, _
                            wsOut.Cells(FirstOutputCell.Row + curRow - 2, _
                                        FirstOutputCell.Column + maxDepth - 2))
    ' write out the output array
    rngOut = out
End Sub

' Depth-first tree traversal, filling in the node depth and row number
Sub TraverseTreeDepthFirst(ByVal cur As Long, ByVal curDepth As Long, ByRef curRow As Long)
    With nod(cur)

        ' set values of the current node
        .Depth = curDepth
        .OutRow = curRow
        curRow = curRow + 1
        If curDepth > maxDepth Then maxDepth = curDepth

        ' Traverse any children first
        If .HeadIdx > 0 Then
            TraverseTreeDepthFirst .HeadIdx, curDepth + 1, curRow
        End If

        ' Move to next sibling
        If .Flink > 0 Then
            TraverseTreeDepthFirst .Flink, curDepth, curRow
        End If
    End With

End Sub

只需调用OutputIndentedRecords传递源数据范围和输出范围的第一个单元格。

如果您有任何问题，请与我们联系。

以下是如何设置按钮来调用此子例程：

首先，将以下VBA代码添加到主题工作表的代码模块中：

Sub CallOutputIndent()

    Dim src As Range
    Set src = Selection

    OutputIndentedRecords src, Worksheets("OutputWs").Cells(2, 2)

End Sub

将上面的工作表名称从“OutputWs”更改为您输出的工作表的名称。也将（2,2）更改为该工作表上的第一个输出单元格。

接下来，转到源工作表，然后从“插入”菜单中添加按钮/矩形。右键单击它并选择“分配宏...”，然后为其分配CallOutputIdent宏。

要使用它，只需选择输入范围并单击按钮。应该是它。

使用VBA缩进父子列

1 个答案: