[Solved] Build hierarchy type presentation of data in Excel

by


Try this, it makes use of a temporary PivotTable…

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

5

solved Build hierarchy type presentation of data in Excel