Macro to convert an indented hierarchy to a database format Our business intelligence suite outputs data as an indented hierarchy, as below:

Level 1            1000
   Level 2a        600
      Level 3a     500
      Level 3b     100
   Level 2b        400
      Level 3c     400


I've written a macro that converts this into a 'database' format, where only rows with the base (most granular) level are preserved, and the parents are listed to the left as below (this way the # column is summable):

   1         2          3         #
Level 1   Level 2a   Level 3a    500
Level 1   Level 2a   Level 3b    100
Level 1   Level 2b   Level 3c    400


The problem I've been running into is that it takes 5-10 minutes to process a file with ~8000 rows. Although my code works, I'm convinced there's a faster way. See below for my code:

Sub Database()

Application.ScreenUpdating = False

Dim WS      As Worksheet
Dim SR      As Range
Dim Rows    As Integer
Dim Indent  As Integer
Dim TR      As Integer
Dim BR      As Integer

Set WS = ActiveWorkbook.ActiveSheet
'StartCell is a function that returns the address of the first cell in the hierarchy
Set SR = WS.Range(StartCell())
Rows = SR.End(xlDown).Row - SR.Row
BR = SR.End(xlDown).Row
TR = SR.Row

'Insert 4 columns &amp; add headers (Level 1, Level 2, etc.)
For x = 0 To 3
    SR.EntireColumn.Insert
    SR.Offset(-1, -1) = "Level " &amp; x + 3
Next x

x = 0
q = 0

'The main code
Do While x &lt; Rows + 1
    'Identifies a row with base-level indentation &amp; sets indent value to this level
    If Left(SR.Offset(x, 0), 5) = "P_PC7" Then
        Indent = SR.Offset(x, 0).IndentLevel
    End If
    i = 0
    'Loop while the indentation level is greater than one
    Do While Indent &gt; 1
        'Move upwards and check whether indentation of new cell is one less than initial cell
        If SR.Offset(x - i, 0).IndentLevel = Indent - 1 Then
            'If so, this cell is the parent of the initial cell - copy it into the appropriate spot to the left of the base level cell
            SR.Offset(x - i, 0).Copy SR.Offset(x, -1 * (6 - Indent))
            'Set new indent level - the next loop will now look for the parent of the new cell
            Indent = SR.Offset(x - i, 0).IndentLevel
        'If indent level is not one less than initial cell, continue moving upward
        Else: i = i + 1
        End If
    Loop
    x = x + 1
Loop

'Remove all rows that are not base-level
For q = BR To TR Step -1
    If WS.Cells(q, 6).IndentLevel &lt;&gt; 5 Then
       WS.Cells(q, 6).EntireRow.Delete
    End If
Next q

WS.UsedRange.IndentLevel = 0

Application.ScreenUpdating = True

End Sub
Thanks very much to JNevill for his solution - it is indeed significantly faster than my original code. I had to make some changes to accommodate more than one # column, as well as headers to the left of the indented hierarchy column i.e.:

Region        Base Level        Account 1     Account 2    

 USA         Level 1               500           800
 USA             Level 2a          300           400
 USA             Level 2b          200           400


Here is my new code based on JNevill's framework:

Sub HierarchyConvert()


Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim WS                      As Worksheet
Dim SR                      As Range
Dim LastRow                 As Long
Dim rngReadCell             As Range
Dim rngWriteRow             As Range
Dim Indent                  As Integer
Dim LastIndent              As Integer
Dim MaxIndent               As Integer
Dim ValueArray(0 To 19)     As Variant

Set WS = ActiveWorkbook.ActiveSheet
Set SR = WS.Range(StartCell())
LastRow = SR.End(xlDown).Row
MaxIndent = 5

Set rngWriteRow = WS.Rows(SR.Row)

For x = 0 To 4
    SR.Offset(0, 1).EntireColumn.Insert
    SR.Offset(-1, 1) = "Level " &amp; 7 - x
Next x

SR.Offset(-1, 0) = "Level 2"
SR.Offset(-1, 5) = "PC"

For Each rngReadCell In WS.Range(SR.Address &amp; ":B" &amp; LastRow)
    Indent = rngReadCell.IndentLevel
    If Indent &lt;= LastIndent And LastIndent &lt;&gt; 0 Then
        Set rngWriteRow = rngWriteRow.Offset(1)
        For i = 1 To Indent
            rngWriteRow.Cells(1, i + 1).Value = rngWriteRow.Cells(1, i + 1).Offset(-1).Value
        Next i
    End If
    rngWriteRow.Cells(Indent + 2).Value = Trim(rngReadCell.Value)
    If Indent = MaxIndent Then
        'Copies leftmost header from base-level row to top left of write-row
        rngWriteRow.Cells(1) = rngReadCell.Offset(, -1).Value
        'Copies data to right of base-level row to the write-row
        For Z = 0 To 19
            ValueArray(Z) = rngReadCell.Offset(, Z + 6).Value
        Next Z
        For M = 0 To 19
            rngWriteRow.Cells(Indent + M + 3).Value = ValueArray(M)
        Next M
    End If
    LastIndent = Indent
Next rngReadCell

Range("A" &amp; SR.Offset(0, 1).End(xlDown).Row + 1 &amp; ":Z" &amp; LastRow + 1).ClearContents
WS.UsedRange.IndentLevel = 0

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub