使用VBA缩进父子列 [英] Using VBA to indent parent child columns

问题描述

我有下表，需要缩进父母关系的帮助.根节点从0开始，可以像子关系一样遍历1000多个级别.

I have the table below and need help indenting parent child relationships. The root node starts at 0 and can traverse 1000+ levels deep as can the child relationships.

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

How do i achieve this in 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

我想在下面的列中显示.

I would like to show this in columns as below.

推荐答案

以下Excel-VBA模块对我有用.

The following Excel-VBA module works for me.

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 ，传入源数据范围和输出范围的第一个单元格即可.

Just call OutputIndentedRecords passing in the range of the source data and the first cell of the output range.

如果您有任何疑问，请告诉我.

Let me know if you have any questions.

以下是设置按钮以调用此子例程的方法:

Here's how to setup a button to call this subroutine:

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

First, add the following VBA code to your subject worksheet's code module:

Sub CallOutputIndent()

    Dim src As Range
    Set src = Selection

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

End Sub

将上面的工作表名称从"OutputWs"更改为您输出的工作表名称.还可以将(2,2)更改为该工作表上第一个输出单元格应该是的形式.

Change the Worksheet name above from "OutputWs" to whatever you output worksheet is named. also change the (2,2) to whatever the first output cell on that worksheet should be.

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

Next, go to your source worksheet and from the "Insert" menu, add a button/rectangular shape. Right-click it and pick "Assign Macro..", and then assign the CallOutputIdent macro to it.

要使用它，只需选择输入范围，然后单击按钮.应该就是这样.

To use it, just select the input range and click the button. that should be it.

这篇关于使用VBA缩进父子列的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！