Excel VBA Найти заголовки группировок и вывести с родителями

Заметка по VBA В excel. Макрос находит ячейки в диапазоне A7:A20000 на первом листе (по индексу) длиной более 3 и выводит списком. К ним прибавляет также уровень группировки, номер строки и номер строки родителя, пригодится при построении иерархий

Sub SearchHead()
    Dim RangeForSearch As Range
    Set RangeForSearch = Worksheets(1).Range("A7:A20000")
    Dim LenStr As Integer, LevelGroup As Integer, CurrentResultRow As Integer, ParrentLevelID As Integer, StrResultRange As Integer
    LenStr = 3
    CurrentResultRow = 2
    ParrentLevelGroup = 1
     
    Columns("A:F").ClearContents
 
     
    Cells(1, 1).Value = "ParentLevel"
    Cells(1, 2).Value = "Level"
    Cells(1, 3).Value = "NameLevel"
    Cells(1, 4).Value = "LevelID"
    Cells(1, 5).Value = "ParrentLevelID"
    Cells(1, 6).Value = "ParrentNameID"
     
    For Each Cell In RangeForSearch.Cells
       If Len(Cell.Value) > LenStr Then
             
            LevelGroup = Worksheets(1).Rows(Cell.Row).OutlineLevel
             
            Cells(CurrentResultRow, 2).Value = LevelGroup
            Cells(CurrentResultRow, 3).Value = Cell.Value
            Cells(CurrentResultRow, 4).Value = Cell.Row
             
            ParrentLevelID = Cell.Row
             
            If LevelGroup > 1 Then
                Cells(CurrentResultRow, 1).Value = LevelGroup - 1
                For StrResultRange = CurrentResultRow To 1 Step -1
                    If Cells(StrResultRange, 2) = LevelGroup - 1 Then
                        Cells(CurrentResultRow, 5).Value = Cells(StrResultRange, 4).Value
                        Cells(CurrentResultRow, 6).Value = Cells(StrResultRange, 3).Value
                        Exit For
                    End If
                Next StrResultRange
            End If
             
            CurrentResultRow = CurrentResultRow + 1
       End If
    Next
End Sub

Если в столбце А во всех ячейках длина более 3х, тогда скрипт не подойдет. Как выцепить только заголовки я не придумал

Тот же вариант, но в 30 раз быстрее

Sub SearchHead()
    Dim RangeForSearch As Range
    Dim arr
    Set RangeForSearch = Worksheets(1).Range("A7:A20000")
    Dim LenStr As Integer, LevelGroup As Integer, CurrentResultRow As Integer, ParrentLevelID As Integer, StrResultRange As Integer
    LenStr = 3
    CurrentResultRow = 2
    ParrentLevelGroup = 1
      
    Columns("A:F").ClearContents
    arr = Range(Cells(1, 1), Cells(20000, 6)).Value
  
      
    arr(1, 1) = "ParentLevel"
    arr(1, 2) = "Level"
    arr(1, 3) = "NameLevel"
    arr(1, 4) = "LevelID"
    arr(1, 5) = "ParrentLevelID"
    arr(1, 6) = "ParrentNameID"
      
    For Each Cell In RangeForSearch.Cells
       If Len(Cell.Value) > LenStr Then
              
            LevelGroup = Worksheets(1).Rows(Cell.Row).OutlineLevel
              
            arr(CurrentResultRow, 2) = LevelGroup
            arr(CurrentResultRow, 3) = Cell.Value
            arr(CurrentResultRow, 4) = Cell.Row
              
            ParrentLevelID = Cell.Row
              
            If LevelGroup > 1 Then
                arr(CurrentResultRow, 1) = LevelGroup - 1
                For StrResultRange = CurrentResultRow To 1 Step -1
                    If arr(StrResultRange, 2) = LevelGroup - 1 Then
                        arr(CurrentResultRow, 5) = arr(StrResultRange, 4)
                        arr(CurrentResultRow, 6) = arr(StrResultRange, 3)
                        Exit For
                    End If
                Next StrResultRange
            End If
              
            CurrentResultRow = CurrentResultRow + 1
       End If
    Next
    Cells(1, 1).Resize(20000, 6).Value = arr
End Sub