在 Excel 中构建数据的层次结构类型表示

Question

我尝试使用 vba 将我的 excel 数据转换为树数据。

Sub MakeTree()

    Dim r As Integer
    ' Iterate through the range, looking for the Root
    For r = 1 To Range("Data").Rows.Count
        If Range("Data").Cells(r, 1) = "Root" Then
            DrawNode Range("Data").Cells(r, 2), 0, 0
        End If
    Next

End Sub

Sub DrawNode(ByRef header As String, ByRef row As Integer, ByRef depth As Integer)
'The DrawNode routine draws the current node, and all child nodes.
' First we draw the header text:
    Cells(Range("Destination").row + row, Range("Destination").Column + depth) = header

    Dim r As Integer
    'Then loop through, looking for instances of that text
    For r = 1 To Range("Data").Rows.Count
        If Range("Data").Cells(r, 1) = header Then
        'Bang!  We've found one!  Then call itself to see if there are any child nodes
            row = row + 1
            DrawNode Range("Data").Cells(r, 2), row, depth + 1
        End If
    Next
End Sub

我的excel数据是这样的，

我尝试使用我的 vba 代码来转换这样的树数据。

但上面的代码对我不起作用。

有人推荐我吗？

谢谢

Answer 1

试试这个，它使用了一个临时数据透视表...

Option Explicit

Sub TestMakeTree()


    Dim wsData As Excel.Worksheet
    Set wsData = ThisWorkbook.Worksheets.Item("Sheet1")

    Dim rngData As Excel.Range
    Set rngData = wsData.Range("Data")  '<----------------- this differs for me


    Dim vTree As Variant
    vTree = MakeTreeUsingPivotTable(ThisWorkbook, rngData)

    '* print it out next to data, you'd choose your own destination

    Dim rngDestinationOrigin As Excel.Range
    Set rngDestinationOrigin = wsData.Cells(rngData.Row, rngData.Columns.Count + 2)

    rngDestinationOrigin.Resize(UBound(vTree, 1), UBound(vTree, 2)) = vTree


End Sub

Function MakeTreeUsingPivotTable(ByVal wb As Excel.Workbook, ByVal rngData As Excel.Range) As Variant


    Dim oPivotCache As PivotCache
    Set oPivotCache = CreatePivotCache(wb, rngData)


    Application.ScreenUpdating = False
    Dim wsTemp As Excel.Worksheet
    Set wsTemp = wb.Worksheets.Add


    Dim oPivotTable As Excel.PivotTable
    Set oPivotTable = CreatePivotTableAndAddColumns(wsTemp, oPivotCache, rngData.Rows(1))
    oPivotTable.RowAxisLayout xlOutlineRow
    oPivotTable.ColumnGrand = False
    oPivotTable.RowGrand = False

    MakeTreeUsingPivotTable = oPivotTable.TableRange1.Value2
    Application.DisplayAlerts = False
    wsTemp.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Function

Function CreatePivotTableAndAddColumns(ByVal wsDestination As Excel.Worksheet, _
            ByVal oPivotCache As Excel.PivotCache, ByVal rngColumnHeaders As Excel.Range)
    Const csTEMP_PIVOT_NAME As String = "TempMakeTreePivot"
    Dim sThirdRowDown As String
    sThirdRowDown = "'" & wsDestination.Name & "'!R3C1"

    Dim oPivotTable As Excel.PivotTable
    Set oPivotTable = oPivotCache.CreatePivotTable(TableDestination:=sThirdRowDown, _
                    TableName:=csTEMP_PIVOT_NAME, DefaultVersion:=xlPivotTableVersion15)

    Dim rngColumnLoop As Excel.Range, lLoop As Long
    For Each rngColumnLoop In rngColumnHeaders.Cells
        lLoop = lLoop + 1
        With oPivotTable.PivotFields(rngColumnLoop.Value2)
            .Orientation = xlRowField
            .Position = lLoop
        End With

    Next rngColumnLoop

    Set CreatePivotTableAndAddColumns = oPivotTable

End Function

Function CreatePivotCache(ByVal wb As Excel.Workbook, ByVal rngData As Excel.Range)
    Dim sFullyQualified As String
    sFullyQualified = "'" & rngData.Parent.Name & "'!" & rngData.Address

    Dim oPivotCache As PivotCache
    Set oPivotCache = wb.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        sFullyQualified, Version:=xlPivotTableVersion15)
    Set CreatePivotCache = oPivotCache
End Function

Answer 2

另一个提议

Sub aaargh()
Dim o(3)
    Set ws1 = Sheet1 ' source sheet to adapt
    Set ws2 = Sheet3 ' target sheet to adapt
    With ws1
        nv = .Cells(.Rows.Count, 1).End(xlUp).Row
        .Range("A1:C" & nv).Sort key1:=.Range("a1"), order1:=xlAscending, _
                                 key2:=.Range("B1"), order2:=xlAscending, _
                                 key3:=.Range("C1"), order3:=xlAscending, _
                                 Header:=xlYes
        ctrl = 0
        For i = 2 To nv
            fl = False
            For j = 1 To 3
                If o(j) <> .Cells(i, j) Or fl = True Then
                    ctrl = ctrl + 1
                    o(j) = .Cells(i, j)
                    ws2.Cells(ctrl, j) = o(j)
                    fl = True
                End If
            Next j
            ctrl = ctrl + 1
            ws2.Cells(ctrl, 4) = .Cells(i, 4)
        Next i
    End With
End Sub