Построение типа иерархического представления данных в Excel

Question

Я пытаюсь преобразовать данные excel в данные дерева с помощью vba.

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 

My 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