Преобразование таблицы с многоуровневой структурой данных

Sub Преобразовать_по_группировке()
    Dim i&, k&, LastRow&, Level1Row&, Level2Row&
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Application.ScreenUpdating = False
    With [C3:G3]: .UnMerge: .Value = [C5:G5].Value: End With
    Columns("C:D").Insert Shift:=xlToRight
    [C3] = [B4]
    [D3] = [B5]
    For i = LastRow To 4 Step -1
        For k = i To 1 Step -1
            If Rows(k).OutlineLevel = 1 Then Level1Row = k: Exit For
        Next k
        For k = i To 1 Step -1
            If Rows(k).OutlineLevel = 2 Then Level2Row = k: Exit For
        Next k
        If Rows(i).OutlineLevel = 3 Then
            Cells(i, 4) = Cells(i, 2)
            Cells(i, 3) = Cells(Level2Row, 2)
            Cells(i, 2) = Cells(Level1Row, 2)
        ElseIf i = Level1Row Or i = Level2Row Then
            Rows(i).Delete Shift:=xlUp
        End If
    Next i
    Rows("4:" & LastRow).ClearOutline
End Sub

Sub       
Dim i&, k&, LastRow&, Level1Row&   
 LastRow = Cells(Rows.Count, 2).End(xlUp).Row    
Application.ScreenUpdating = False    
With [C3:G3]: .UnMerge: .Value = [C4:G4].Value: End With    
Columns("C").Insert Shift:=xlToRight    
[C3] = [B4]
For i = LastRow To 4 Step -1       
 For k = i To 1 Step -1           
 If Rows(k).OutlineLevel = 1 Then Level1Row = k: Exit For        
Next k        
If Rows(i).OutlineLevel = 2 Then            
Cells(i, 3) = Cells(i, 2)           
 ' Cells(i, 3) = Cells(Level2Row, 2)           
Cells(i, 2) = Cells(Level1Row, 2)        
ElseIf i = Level1Row Then            
Rows(i).Delete Shift:=xlUp        
End If    
Next i    
Rows("4:" & LastRow).ClearOutline
End Sub

Sub Преобразовать_по_группировке()
    Dim i&, k&, n&, FirstRow&, LastRow&, LevelRow&(), MaxLevel%
    LastRow = Cells(Rows.Count, 2).End(xlUp).Row
    Application.ScreenUpdating = False
    For k = 1 To LastRow
        If Trim(Cells(k, 2)) = "Номенклатура" Then FirstRow = k + 1: Exit For
    Next k
    For k = FirstRow To LastRow
        If MaxLevel < Rows(k).OutlineLevel Then MaxLevel = Rows(k).OutlineLevel
    Next k
    ReDim LevelRow&(MaxLevel)
    If MaxLevel = 3 Then With [C3:G3]: .UnMerge: .Value = [C5:G5].Value: End With
    For n = MaxLevel To 2 Step -1
        Columns("C").Insert Shift:=xlToRight
        Range("C" & (FirstRow - 1)) = Range("B" & (FirstRow - 2 + n))
    Next n
    For i = LastRow To FirstRow Step -1
        For n = 1 To MaxLevel - 1
            For k = i To FirstRow Step -1
                If Rows(k).OutlineLevel = n Then LevelRow(n) = k: Exit For
            Next k
        Next n
        If Rows(i).OutlineLevel = MaxLevel Then
            Cells(i, MaxLevel + 1) = Cells(i, 2)
            For n = 1 To MaxLevel - 1
                Cells(i, n + 1) = Cells(LevelRow(n), 2)
            Next n
        Else
            For n = 1 To MaxLevel - 1
                If i = LevelRow(n) Then Rows(i).Delete Shift:=xlUp
            Next n
        End If
    Next i
    Rows("1:" & LastRow).ClearOutline
End Sub

Option Explicit
 
 
 
Sub Преобразовать_по_группировке()
Dim i&, k&, LastRow&, Level1Row&, Level2Row&
Dim kmax As Long, kx(0 To 20) As String, j, s1, s2
Dim ws2 As Worksheet
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
Set ws2 = Excel.Worksheets("zrab")
 
 
  For k = 1 To LastRow
  If Rows(k).OutlineLevel > kmax Then kmax = Rows(k).OutlineLevel
  Cells(k, 1) = Rows(k).OutlineLevel
  Next k
 
Debug.Print kmax
''Exit Sub
For i = 1 To LastRow
  k = Rows(i).OutlineLevel
  
  s1 = Cells(i, 2) & ""
  
  If s1 Like "*, шт*" Then
  For j = k To kmax
  kx(j) = ""
  Next j
  kx(kmax) = s1
  Else
  For j = k To kmax
  kx(j) = ""
  Next j
  kx(k) = s1
  End If
 
 
  For j = 1 To kmax
  ws2.Cells(i, j) = kx(j)
  Next j
  
  For j = 3 To 7
  ws2.Cells(i, j + kmax) = Cells(i, j)
  Next j
 
Next i
End Sub