Option Explicit

Private Const source_sheet = "Лист1"
Private Const target_sheet = "Лист2"
Private Const source_first_row = 2
Private Const target_first_row = 2
Private Const source_key_column1 = 1
Private Const source_key_column2 = 2
Private Const source_sum_column = 3
Private Const target_key_column1 = 1
Private Const target_key_column2 = 2
Private Const target_sum_column = 3

Sub mySum()
    Dim dic As Object
    Set dic = GetMainDic()
    If dic Is Nothing Then Exit Sub
    
    PrintDic dic
End Sub

Private Sub PrintDic(dic As Object)
    Const buf_size = 20000
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim sh As Worksheet
    Set sh = Sheets(target_sheet)
    With sh
        Dim r1 As Range: Set r1 = .Cells(target_first_row, target_key_column1)
        Dim r2 As Range: Set r2 = .Cells(target_first_row, target_key_column2)
        Dim rs As Range: Set rs = .Cells(target_first_row, target_sum_column)
        
        Dim ya As Long
        Dim arr As Variant
        Dim brr As Variant
        Dim crr As Variant
        
        Dim bic As Object
        Dim iKey1 As Long
        Dim iKey2 As Long
        Dim key1 As Variant
        Dim key2 As Variant
        For iKey1 = 0 To dic.Count - 1
            key1 = dic.Keys()(iKey1)
            Set bic = dic.Items()(iKey1)
            For iKey2 = 0 To bic.Count - 1
                key2 = bic.Keys()(iKey2)
                
                If IsEmpty(arr) Then
                    If r1.Row + buf_size - 1 <= .Rows.Count Then
                        ReDim arr(1 To buf_size, 1 To 1)
                    Else
                        ReDim arr(1 To .Rows.Count - r1.Row + 1, 1 To 1)
                    End If
                    brr = arr
                    crr = arr
                    ya = 0
                End If
                
                ya = ya + 1
                arr(ya, 1) = key1
                brr(ya, 1) = key2
                crr(ya, 1) = bic.Items()(iKey2)
                
                If ya = UBound(arr, 1) Then
                    r1.Resize(UBound(arr, 1)).Value = arr
                    arr = Empty
                    r2.Resize(UBound(brr, 1)).Value = brr
                    brr = Empty
                    rs.Resize(UBound(crr, 1)).Value = crr
                    
                    If r1.Row + buf_size <= .Rows.Count Then
                        Set r1 = r1.Cells(1 + buf_size)
                        Set r2 = r2.Cells(1 + buf_size)
                        Set rs = rs.Cells(1 + buf_size)
                    Else
                        Exit Sub
                    End If
                    crr = Empty
                End If
            Next
        Next
    End With

    r1.Resize(UBound(arr, 1)).Value = arr
    arr = Empty
    r2.Resize(UBound(brr, 1)).Value = brr
    brr = Empty
    rs.Resize(UBound(crr, 1)).Value = crr
    crr = Empty
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetMainDic() As Object
    Dim sh As Worksheet
    Set sh = Sheets(source_sheet)
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, source_key_column1).End(xlUp).Row
        If yy <= source_first_row Then Exit Function
        
        Dim arr As Variant
        Dim brr As Variant
        Dim crr As Variant
        arr = .Cells(1, source_key_column1).Resize(yy).Value
        brr = .Cells(1, source_key_column2).Resize(yy).Value
        crr = .Cells(1, source_sum_column).Resize(yy).Value
    End With
    
    Dim bic As Object
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim ya As Long
    For ya = source_first_row To UBound(arr, 1)
        If IsNumeric(crr(ya, 1)) Then
            If ya = source_first_row Then
                Set bic = CreateObject("Scripting.Dictionary")
            Else
                If arr(ya, 1) <> arr(ya - 1, 1) Then
                    If Not dic.Exists(arr(ya, 1)) Then
                        Set bic = CreateObject("Scripting.Dictionary")
                    Else
                        Set bic = dic.Item(arr(ya, 1))
                    End If
                End If
            End If
            bic.Item(brr(ya, 1)) = bic.Item(brr(ya, 1)) + crr(ya, 1)
            
            If ya = UBound(arr, 1) Then
                Set dic.Item(arr(ya, 1)) = bic
                Set bic = Nothing
            ElseIf arr(ya, 1) <> arr(ya + 1, 1) Then
                Set dic.Item(arr(ya, 1)) = bic
                Set bic = Nothing
            End If
        End If
    Next
    
    Set GetMainDic = dic
End Function

Option Explicit

Sub mySum_OneDic()
    Dim dic As Object
    Set dic = GetMainDic()
    If dic Is Nothing Then Exit Sub
    
    PrintDic dic
End Sub

Sub CompareTime()
    Dim dt As Date
    
    dt = Now
    mySum_DicOfDic
    Debug.Print Format(Now - dt, "ss")
    
    dt = Now
    mySum_OneDic
    Debug.Print Format(Now - dt, "ss")
End Sub

Private Sub PrintDic(dic As Object)
    Const buf_size = 20000
    
    Dim Application_Calculation As Long
    Application_Calculation = Application.Calculation
    Application.Calculation = xlCalculationManual
    
    Dim sh As Worksheet
    Set sh = Sheets(target_sheet)
    With sh
        Dim r1 As Range: Set r1 = .Cells(target_first_row, target_key_column1)
        Dim r2 As Range: Set r2 = .Cells(target_first_row, target_key_column2)
        Dim rs As Range: Set rs = .Cells(target_first_row, target_sum_column)
        
        Dim ya As Long
        Dim arr As Variant
        Dim brr As Variant
        Dim crr As Variant
        Dim krr As Variant
        Dim srr As Variant
        Dim trr As Variant
        
        krr = dic.Keys()
        srr = dic.Items()
        Set dic = Nothing
        
        ReDim arr(1 To UBound(krr) + 1, 1 To 1)
        brr = arr
        crr = arr
        
        For ya = 1 To UBound(arr, 1)
            trr = Split(krr(ya - 1), "#")
            arr(ya, 1) = trr(0)
            brr(ya, 1) = trr(1)
            crr(ya, 1) = srr(ya - 1)
            DoEvents
        Next
        
    End With

    r1.Resize(UBound(arr, 1)).Value = arr
    arr = Empty
    r2.Resize(UBound(brr, 1)).Value = brr
    brr = Empty
    rs.Resize(UBound(crr, 1)).Value = crr
    crr = Empty
    
    Application.Calculation = Application_Calculation
End Sub

Private Function GetMainDic() As Object
    Dim sh As Worksheet
    Set sh = Sheets(source_sheet)
    With sh
        Dim yy As Long
        yy = .Cells(.Rows.Count, source_key_column1).End(xlUp).Row
        If yy <= source_first_row Then Exit Function
        
        Dim arr As Variant
        Dim brr As Variant
        Dim crr As Variant
        arr = .Cells(1, source_key_column1).Resize(yy).Value
        brr = .Cells(1, source_key_column2).Resize(yy).Value
        crr = .Cells(1, source_sum_column).Resize(yy).Value
    End With
    
    Dim dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    
    Dim sKey As String
    
    Dim ya As Long
    For ya = source_first_row To UBound(arr, 1)
        If IsNumeric(crr(ya, 1)) Then
            sKey = myKey(arr(ya, 1), brr(ya, 1))
            dic.Item(sKey) = dic.Item(sKey) + crr(ya, 1)
        End If
    Next
    
    Set GetMainDic = dic
End Function

Private Function myKey(v1 As Variant, v2 As Variant)
    myKey = v1 & "#" & v2
End Function