Option Explicit

Sub QWERT()
Dim M()
Dim RZ()
Dim R, C
 чистиить 'вызываем процедуру очистки лста результата
Range(Лист1.Cells(1, 1), Лист1.Cells(5, 8)).Copy Лист2.Cells(1, 1) 'копируем шапку
M = СУММИРОВАТЬ(Cells(6, 3)) 'вызываем функцию суммирования с предачей левой верхней ячейки таблицы
Range(Лист2.Cells(7, 2), Лист2.Cells(UBound(M, 2) + 6, 8)) = M 'вываливаем результаты (массив) на лист
'составляем формулы сумм (можно было бы одну и автозаполнение)
Лист2.Cells(UBound(M, 2) + 7, 5).Formula = "=SUM(E7:E" & UBound(M, 2) + 6 & ")"
Лист2.Cells(UBound(M, 2) + 7, 6).Formula = "=SUM(F7:F" & UBound(M, 2) + 6 & ")"
Лист2.Cells(UBound(M, 2) + 7, 7).Formula = "=SUM(G7:G" & UBound(M, 2) + 6 & ")"
Лист2.Cells(UBound(M, 2) + 7, 8).Formula = "=SUM(H7:H" & UBound(M, 2) + 6 & ")"
'форматируем строку сумм
Range(Лист2.Cells(UBound(M, 2) + 7, 2), Лист2.Cells(UBound(M, 2) + 7, 8)).Font.Bold = 1
Лист2.Cells(UBound(M, 2) + 7, 8).NumberFormat = "#,##0.00"
End Sub

Function СУММИРОВАТЬ(Первая_ячейка_таблицы As Range)
Dim M()
Dim LR, LC, R, C, J
Dim REZ()
Dim GRR
Dim S3: Set S3 = CreateObject("Scripting.Dictionary") 'создаём словари для сумм
Dim S4: Set S4 = CreateObject("Scripting.Dictionary")
Dim S5: Set S5 = CreateObject("Scripting.Dictionary")
Dim S6: Set S6 = CreateObject("Scripting.Dictionary")
'определяем границы таблицы
R = Первая_ячейка_таблицы.Row
C = Первая_ячейка_таблицы.Column
LR = Лист1.Cells(Лист1.Rows.Count, 3).End(xlUp).Row
LC = Лист1.Cells(R, Лист1.Columns.Count).End(xlToLeft).Column
M = Range(Лист1.Cells(R, C), Лист1.Cells(LR, LC)) ' загнали всё в массив
For R = 1 To UBound(M) 'по всему массиву
    If M(R, 2) = Empty Then ' если "D" пустая. Теперь она во 2 колонке
    'определяем группу по подгруппе."Группы" это имя таблицы сооветствия. Формула ВПР
        GRR = Application.WorksheetFunction.VLookup(M(R, 1), Range("Группы"), 2) 'определяем группу
    'собственно суммируем по группам
        S3.Item(GRR) = S3.Item(GRR) + M(R, 3)
        S4.Item(GRR) = S4.Item(GRR) + M(R, 4)
        S5.Item(GRR) = S5.Item(GRR) + M(R, 5)
        S6.Item(GRR) = S6.Item(GRR) + M(R, 6)
    End If
Next R
'Для сбора данных из словарей сумм присваиваем массиву массив ключей
M = S3.keys '
ReDim REZ(UBound(M), 7) 'переназначаем размер результирующего массива
For R = 0 To UBound(M) 'по всем группам выводим названия и суммы
 REZ(R, 0) = M(R)
 REZ(R, 3) = S3.Item(M(R))
 REZ(R, 4) = S4.Item(M(R))
 REZ(R, 5) = S5.Item(M(R))
 REZ(R, 6) = S6.Item(M(R))
Next
СУММИРОВАТЬ = REZ 'возвращаем нужный массив
End Function

Sub чистиить()
Лист2.Cells.ClearContents 'чистить содержимое
Лист2.Cells.Font.Bold = 0 'убрать жироность
Лист2.Cells.Interior.ColorIndex = 0 'убрать заливку
Лист2.Cells.UnMerge 'разгруппировать
Лист2.Cells.Borders.LineStyle = xlNone 'убрать линии сетки
End Sub