Суммирование значений в массиве макросом

 Sub example()
 Dim i&, i1&, i2&, j&, s1&
 unicum
 i1 = Range("D4").End(xlDown).Row
 i2 = Range("J" & Cells.Rows.Count).End(xlUp).Row
  For j = 4 To i2
       s1 = 0
     For i = 4 To i1
      If Range("D" & i) = Range("J" & j) Then
        s1 = s1 + Range("F" & i)
        Range("I" & j) = Range("C" & i)
        Range("H" & j) = Range("B" & i)
      End If
    Next i
    Range("K" & j) = s1
 Next j
End Sub

Sub clean()
Dim i2&
i2 = Range("J" & Cells.Rows.Count).End(xlUp).Row
Range("H4:Q" & i2).ClearContents
End Sub

Sub unicum()
Dim c As Range, i1&, i2&, m%
i1 = Range("D4").End(xlDown).Row
i2 = Range("J" & Cells.Rows.Count).End(xlUp).Row
Dim V As New Collection
On Error Resume Next
For Each c In Range("D4:D" & i1)
    V.Add c, c
Next c
On Error GoTo 0
m = 3
For Each i In V
    m = m + 1
    Range("J" & m) = i
Next i
Sort
End Sub

Sub Sort()
Dim m&, n&, j2&, t
i2 = Range("J" & Cells.Rows.Count).End(xlUp).Row
For m = 4 To i2
   For n = m + 1 To i2
     If Range("J" & m) > Range("J" & n) Then
     t = Range("J" & n)
     Range("J" & n) = Range("J" & m)
     Range("J" & m) = t
     End If
   Next n
Next m
End Sub

Sub insert7()
    Dim arr1(), i1&, i&, j&, k&, t1(1 To 4), t$, n&, x&, d, arr2()
    With Sheets("Лист1")
    i1 = .Range("D" & Cells.Rows.Count).End(xlUp).Row
        arr1 = .Range("B4:F" & i1).Value
        ReDim arr2(1 To UBound(arr1), 1 To UBound(arr1, 2))
        Set d = CreateObject("scripting.dictionary")
        For i = 1 To UBound(arr1)
            t = arr1(i, 2)
            t = arr1(i, 2) & arr1(i, 3)
            If d.exists(t) Then
                x = d.Item(t)
                arr2(x, UBound(arr2, 2)) = arr2(x, UBound(arr2, 2)) + arr1(i, UBound(arr2, 2))
            Else
                n = n + 1: d.Item(t) = n
                For j = 1 To UBound(arr2, 2): arr2(n, j) = arr1(i, j): Next
            End If
        Next
        For i = 1 To n: arr2(i, UBound(arr2, 2) - 1) = arr2(i, UBound(arr2, 2)): arr2(i, UBound(arr2, 2)) = "": Next i
        For i = 1 To n
          For j = i + 1 To n
             If arr2(i, 3) > arr2(j, 3) Then
 For k = 1 To UBound(arr2, 2) - 1: t1(k) = arr2(j, k): arr2(j, k) = arr2(i, k): arr2(i, k) = t1(k): Next
             End If
          Next
    Next
        .Range("H4").Resize(n, UBound(arr2, 2)).Value = arr2
    End With
End Sub

Sub tt()
    Dim a(), t$, i&, ii&, x&
 
    With CreateObject("scripting.dictionary"): .comparemode = 1
        a = [a1].CurrentRegion.Value
        a(1, 4) = a(1, 5)
        a(1, 5) = a(1, 6)
        ii = 1
        For i = 2 To UBound(a)
            t = a(i, 1) & "| " & a(i, 2) & "|" & a(i, 3)
            If Not .exists(t) Then
                ii = ii + 1: .Item(t) = ii
                For x = 1 To 3: a(ii, x) = a(i, x): Next
                a(ii, 4) = a(i, 5)
                a(ii, 5) = a(i, 6)
            Else
                x = .Item(t)
                a(x, 4) = a(x, 4) + a(i, 5)
                a(x, 5) = a(x, 5) + a(i, 6)
            End If
        Next
 
        Range("N1").Resize(.Count + 1, UBound(a, 2) - 1).Value = a
    End With
 
End Sub

Option Explicit
 
Sub tt()
    Dim a(), t$, i&, ii&, x&
 
    With CreateObject("scripting.dictionary"): .comparemode = 1
        a = [a1].CurrentRegion.Value
        ii = 1: a(ii, 4) = a(1, 5): a(ii, 5) = a(1, 6)
        For i = 2 To UBound(a)
            t = a(i, 1) & "| " & a(i, 2) & "|" & a(i, 3)
            If Not .exists(t) Then
                ii = ii + 1: .Item(t) = ii
                For x = 1 To 3: a(ii, x) = a(i, x): Next
                a(ii, 4) = a(i, 5): a(ii, 5) = a(i, 6)
            Else
                x = .Item(t)
                a(x, 4) = a(x, 4) + a(i, 5): a(x, 5) = a(x, 5) + a(i, 6)
            End If
        Next
    End With
 
    Range("N1").Resize(ii, UBound(a, 2) - 1).Value = a
 
End Sub

Sub yyy()
    Dim z(), i&, j&, m&, k&, i1&
    Application.ScreenUpdating = False
    i1 = Sheets("Лист1").Range("A" & Cells.Rows.Count).End(xlUp).Row
    z = Sheets("Лист1").Range("A2:F" & i1).Value
    With CreateObject("scripting.dictionary"): .comparemode = 1
        For i = 1 To UBound(z)
            If .exists(z(i, 2)) = False Then
                m = m + 1: .Item(z(i, 2)) = m: For j = 1 To UBound(z, 2): z(m, j) = z(i, j): Next
            Else
            For k = 4 To UBound(z, 2): z(.Item(z(i, 2)), k) = z(.Item(z(i, 2)), k) + z(i, k): Next
            End If
        Next
    Sheets("Лист1").Range("G2").Resize(.Count, UBound(z, 2)) = z
   End With
  With Sheets("Лист1")
      .Columns("J").Delete Shift:=xlToLeft
      .Range("G1:I1").Value = .Range("A1:C1").Value
      .Range("J1:K1").Value = .Range("E1:F1").Value
      .Columns("G:K").AutoFit
End With
 Application.ScreenUpdating = True
End Sub