Option Explicit
'===========================================================================================
Sub GetUniq()
Dim x, arr, arrInsert(), dic As Object, r&, n&, t!
Const delim$ = "%$%", colVal As Byte = 4, colPack As Byte = 5, colKey As Byte = 7, colInsert As Byte = 11

t = Timer
arr = Cells(1, 1).Resize(Cells(Rows.Count, colKey).End(xlUp).Row, colInsert)
ReDim arrInsert(1 To UBound(arr, 1), 1 To 3)
Set dic = CreateObject("scripting.dictionary")

    For r = 1 To UBound(arr, 1)
        If Not dic.exists(arr(r, colKey)) Then
            x = dic(arr(r, colKey)): n = n + 1
            arrInsert(n, 1) = arr(r, colKey)
            arrInsert(n, 2) = WorksheetFunction.SumIf(Cells(1, colKey).Resize(UBound(arr, 1)), arr(r, colKey), Cells(1, colVal).Resize(UBound(arr, 1)))
            arrInsert(n, 3) = WorksheetFunction.SumIf(Cells(1, colKey).Resize(UBound(arr, 1)), arr(r, colKey), Cells(1, colPack).Resize(UBound(arr, 1)))
        End If
    Next r

Application.ScreenUpdating = False
Cells(1, colInsert).Resize(n, 3).Value2 = arrInsert
Application.ScreenUpdating = True
MsgBox "Вставлено уникальных строк: " & n & vbLf & "Время работы: " & Format$(1000 * (Timer - t), "0 ms"), vbInformation, "ГОТОВО"
End Sub
'===========================================================================================