Оптимизация процедуры агрегирования иерархических данных

Option Explicit
 
Sub ColumnsSummation()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Dim current_col As Byte
For current_col = 2 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
 
    'Так писать конечно нельзя. Процедура которая вызывается 5 раз это
    'полный ахтунг, но работает)
    Call summation(current_col)
    Call summation(current_col)
    Call summation(current_col)
    Call summation(current_col)
    Call summation(current_col)
    
Next current_col
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 
Sub summation(current_col As Byte)
Dim level_column: level_column = 1
'Dim current_col: current_col = 10
Dim row As Long, row1 As Long
Dim curr_level As Integer, level As Integer
Dim sum As Currency
 
For row = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
 
    sum = 0
    curr_level = ActiveSheet.Cells(row, level_column)
    
    row1 = row + 1
    level = ActiveSheet.Cells(row1, level_column)
    Do While (level <> curr_level) And level <> 0 'попробуем исключить это условие
        If level - curr_level = 1 Then
            If IsNumeric(ActiveSheet.Cells(row1, current_col)) Then
                sum = sum + ActiveSheet.Cells(row1, current_col)
            Else
                MsgBox "В ячейке " & ActiveSheet.Cells(row1, current_col).Address & " стоит не числовое значение" & vbCrLf & _
                    "Процедура суммирования будет завершена." & vbCrLf & _
                    "Исправте значение и запустите её заново."
                End
            End If
        End If
        row1 = row1 + 1
        level = ActiveSheet.Cells(row1, level_column)
    Loop
 
    If curr_level <> 5 Then 'исключаем самый нижний уровень значения которого являются не агрегированными.
        ActiveSheet.Cells(row, current_col) = sum
    End If
Next row
 
End Sub

Option Explicit
 
Sub ColumnsSummation()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 
Dim current_col As Byte
For current_col = 2 To ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
    Call summation2(current_col)
Next current_col
 
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
 
 
Sub summation2(current_col As Byte)
Dim i As Integer
For i = 1 To 5
  Dim level_column: level_column = 1
  'Dim current_col: current_col = 10
  Dim row As Long, row1 As Long
  Dim curr_level As Integer, level As Integer
  Dim sum As Currency
   
  For row = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
   
      sum = 0
      curr_level = ActiveSheet.Cells(row, level_column)
      
      row1 = row + 1
      level = ActiveSheet.Cells(row1, level_column)
      Do While (level <> curr_level) And level <> 0 'попробуем исключить это условие
          If level - curr_level = 1 Then
              If IsNumeric(ActiveSheet.Cells(row1, current_col)) Then
                  sum = sum + ActiveSheet.Cells(row1, current_col)
              Else
                  MsgBox "В ячейке " & ActiveSheet.Cells(row1, current_col).Address & " стоит не числовое значение" & vbCrLf & _
                      "Процедура суммирования будет завершена." & vbCrLf & _
                      "Исправте значение и запустите её заново."
                  End
              End If
          End If
          row1 = row1 + 1
          level = ActiveSheet.Cells(row1, level_column)
      Loop
   
      If curr_level <> 5 Then 'исключаем самый нижний уровень значения которого являются не агрегированными.
          ActiveSheet.Cells(row, current_col) = sum
      End If
  Next row
Next i
End Sub

Option Explicit
 
Const КолонкаПотомков = 5
 
Sub ColumnsSummation()
    Call СобратьСуммыУПотомков(2) 'начинаем рекурсию со второго ряда
End Sub
 
Private Sub СобратьСуммыУПотомков(ByVal ТекущийРяд As Long, Optional ByRef ТекущийАккумулятор As Range)
    
    Set ТекущийАккумулятор = Cells(ТекущийРяд, 2) 'для примера будем считать только сумму по второну столбцу, но можно добавить аккумуляторы и для других
    
    If Cells(ТекущийРяд, КолонкаПотомков) <> "" Then 'если есть потомки
        
        ТекущийАккумулятор = 0 'обнуляем в этом ряду сумму, а то вдруг она уже посчитана на устаревших данных, а нам то надо считать с нуля
        
        Dim РядПотомка
        For Each РядПотомка In Split(Cells(ТекущийРяд, КолонкаПотомков), " ") 'разделяем строку вида "2 12 33" на массив строк "2", "12" и "33" и обходим его
            
            Dim АккумуляторПотомка As Range 'Эта переменной будет присоено значение в следующей процедуре. Она нужна для возврата значения оттуда
            Call СобратьСуммыУПотомков(РядПотомка, АккумуляторПотомка)
            
            ТекущийАккумулятор = ТекущийАккумулятор + АккумуляторПотомка
        Next РядПотомка
    End If
End Sub