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
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