Expand Rows Based on Column - excel

Question

I am creating hierarchies and need to outline them in the format on the right-hand side. It would be a lot easier if I could simply outline the hierarchy in one column and automatically have it expand (left -> right in the sample).
A few considerations:
Within the first column, the start of a new hierarchy will always be the value 'A'
Hierarchies can range from 2-10 children in length
Any thoughts?

Answer 1

Type the letters in column A only, start each new sequence with the word HEADER. Then run the macro and the expansions should be created.
Sub expand()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim cell As Range, cellHeader As Range
Dim irow As Integer, i As Integer
Dim iCount As Integer, iLast As Long
' find last row in col A
iLast = ws.Range("A" & Rows.Count).End(xlUp).Row
'scan down the sheet
For Each cell In ws.Range("A1:A" & iLast)
If UCase(cell) = "DIRECT" Then
' remember the header line
Set cellHeader = cell
With cellHeader
.BorderAround xlContinuous
.Font.Bold = True
End With
ElseIf Len(cell) > 0 Then
cell.BorderAround xlContinuous
' start of sequence
If cell = "A" Then
irow = 1
iCount = 0
End If
' add header value
With cellHeader.Offset(0, irow)
.Value = "L" & irow
.Font.Bold = True
.BorderAround xlContinuous
End With
' copy cell diagonally upwards
If irow > 1 Then
For i = 1 To irow - 1
cell.Offset(-i, i) = cell.Value
cell.Offset(-i, i).BorderAround xlContinuous
Next
End If
' check max children
iCount = iCount + 1
If iCount > 10 Then
MsgBox "Children count > 10", vbCritical, "Error"
Exit Sub
End If
irow = irow + 1
End If
Next
MsgBox "Expansion Complete", vbInformation
End Sub

Answer 2

You do not answer my questions and I cannot wait, anymore...
Please test the next code, which works based on the thowe assumptions: Your hierarchies in discussion have all the time a kind of header (Direct in column A:A and L1 in B:B). This, or an empty row sets the bottom part of the hierarchy.
Here's the code:
Sub HierarchyArrangeMultipleR()
Dim sh As Worksheet, i As Long, j As Long, lastR As Long, lastH As Long
Dim arrI As Variant, arrTr As Variant, colN As Long, k As Long, h As Long
Set sh = ActiveSheet 'please, use here your worksheet
lastR = sh.Range("A" & sh.Rows.count).End(xlUp).Row
For k = 1 To lastR
If lastH > 0 Then k = lastH + 1
If k >= lastR Then Exit For
Start:
If sh.Range("A" & k).Value = "Direct" And sh.Range("B" & k).Value = "L1" Then
For i = 1 To 10
If sh.Range("A" & k + i).Value = "Direct" Or _
sh.Range("A" & k + i).Value = Empty Then
lastH = k + i - 1: Exit For
End If
Next i
For h = 3 To lastH - k
sh.Cells(k, h) = "L" & h - 1
Next h
Else
k = k + 1: GoTo Start
End If
arrI = sh.Range("A" & k + 1 & ":A" & lastH).Value
ReDim arrTr(1 To UBound(arrI) - 1)
colN = 1
For i = k To lastH - 2
For j = 1 To UBound(arrTr) 'lastH - i + k - 2
arrTr(j) = arrI(j, 1)
Next j
colN = colN + 1
sh.Range(sh.Cells(k + 1, colN), sh.Cells(lastH + 1 - colN, colN)).Value = WorksheetFunction.Transpose(arrTr)
Next i
Erase arrTr
Next k
End Sub