InTeGr87iOn InTeGr87iOn - 3 months ago 12
Vb.net Question

Excel VB to build a Hierarchy / Straw model from cells that are in a single row

I would like your help in helping me figure out how to take a row of cells that are in a flat hierarchy (Cell A:1 = level 1, Cell A:2 = level 2 etc...) and build it out so that each level is on a separate row like a straw model.

What I need:

To-Be What I need

And then this is what I have for example:

As-Is Flat hierarchy

I Just can't wrap my head around what is needed as I have got the code to move cells down and look like a hierarchy but I can't seem to get the logic tweaked just right to give me a clean smooth looking sheet. I will have a lot of different parents with different hierarchies and don't want to have to keep going through them and manually copying and pasting the values.

Here is the code I have been using that I have pulled together from other stackoverflow questions and it gets me somewhat on the right track but need help to see what I am missing to get it to look like the To-Be image above. The code assumes that I have 8 levels in a hierarchy but I want to programically find the lowest level of each hierarchy (most granular level) and skip the idea of having to create and if statement for each level as I could have some hierarchies with 30 child sub levels. : Thoughts?

Sub Button1_Click()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim lcol As Long

For x = 8 To 1 Step -1
lcol = Cells(x, Columns.Count).End(xlToLeft).Column
If IsEmpty(Cells(x, 8)) = False Then
Cells(x, 8).Select
For Z = 1 To 8
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Rows(lcol).EntireRow.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If

If IsEmpty(Cells(x, 7)) = False Then
Cells(x, 7).Select
For Z = 1 To 7
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 6)) = False Then
Cells(x, 6).Select
For Z = 1 To 6
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 5)) = False Then
Cells(x, 5).Select
For Z = 1 To 5
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 4)) = False Then
Cells(x, 4).Select
For Z = 1 To 4
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 3)) = False Then
Cells(x, 3).Select
For Z = 1 To 3
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 2)) = False Then
Cells(x, 2).Select
For Z = 1 To 2
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
If IsEmpty(Cells(x, 1)) = False Then
Cells(x, 1).Select
For Z = 1 To 1
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
Next


End Sub

Answer

I'd use arrays extensively, like follows:

Option Explicit

Sub main()
    Dim myArr As Variant, myArr2() As String
    Dim irow As Long, iCol As Long, irow2 As Long

    With Worksheets("Hierarchy").Range("A1").CurrentRegion
        myArr = .Cells.value
        ReDim myArr2(1 To WorksheetFunction.CountA(.Cells) + .Rows.Count - 1, 1 To .Columns.Count)
    End With

    For irow = LBound(myArr, 1) To UBound(myArr, 1)
        For iCol = LBound(myArr, 2) To UBound(myArr, 2)
            If Not IsEmpty(myArr(irow, iCol)) Then
                irow2 = irow2 + 1
                myArr2(irow2, iCol) = myArr(irow, iCol)
            End If
        Next iCol
        irow2 = irow2 + 1
    Next irow

    Worksheets("Hierarchy").Range("A1").Range("A1").Resize(UBound(myArr2, 1), UBound(myArr2, 2)).value = myArr2
End Sub