Option Explicit
Sub grouping()
Dim dic As New Dictionary, rng As Range, gr As Range
Dim x, arr, lr&, r&, c&

'Application.DisplayAlerts = False
'Range(Cells(4, 3), Cells(lr, 17)).Subtotal GroupBy:=1, Function:=xlAverage, TotalList:=Array(4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15), Replace:=True, PageBreaks:=False, SummaryBelowData:=True

arr = Cells(1, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row, 17)

    For r = 5 To UBound(arr, 1) - 1                             ' заполняем пустые верхними
        For c = 1 To 2
            If Len(arr(r + 1, c)) = 0 Then arr(r + 1, c) = arr(r, c)
        Next c
    Next r

    For r = 5 To UBound(arr, 1)                                 ' проверяем на нули и ошибки + собираем словарь столбцов для скрытия
        For c = 1 To 2
            If Len(arr(r + 1, c)) = 0 Then arr(r + 1, c) = arr(r, c)
        Next c

        For c = 6 To 17
            If IsError(arr(r, c)) Then
                arr(r, c) = Empty: x = dic(c)
            ElseIf arr(r, c) = 0 Then
                arr(r, c) = Empty: x = dic(c)
            End If
        Next c
    Next r
    


Application.ScreenUpdating = False                              ' отключаем обновление экрана
Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)).Value2 = arr ' выгружаем массив обратно на лист

'ActiveSheet.Outline.ShowLevels RowLevels:=3

    If dic.Count > 0 Then                                       ' если что-то есть в словаре, то собираем столбцы в одну группу и скрываем разом
        For Each x In dic.Keys
            If gr Is Nothing Then
                Set gr = Cells(1, c)
            Else
                Set gr = Application.Union(gr, Cells(1, c))
            End If
        Next x
        gr.EntireColumn.Hidden = True
    End If

Application.ScreenUpdating = True                               ' включаем обновление экрана
End Sub