Оптимизация массива данных группировкой строк по нескольким критериям

Sub Оптим()
qwerty = Timer
    Dim arrA() As String
    Dim arrB() As String
    Dim arrC() As Date
    Dim arrD() As Integer
    Dim arrABC() As String
    Dim arrUnic() As String
    Dim lrow As String
    Dim lrow2 As String
    Dim cnt As Integer
    Dim summa As Integer
 
Sheets("исход").Activate
    
lrow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
 
    ReDim arrA(2 To lrow)
    ReDim arrB(2 To lrow)
    ReDim arrC(2 To lrow)
    ReDim arrD(2 To lrow)
    ReDim arrABC(2 To lrow)
    ReDim arrUnic(2 To lrow)
    
For a = 2 To lrow
    arrA(a) = Cells(a, 1)
Next a
For a = 2 To lrow
    arrB(a) = Cells(a, 2)
Next a
For a = 2 To lrow
    arrC(a) = Cells(a, 3)
Next a
For a = 2 To lrow
    arrD(a) = Cells(a, 4)
Next a
For a = 2 To lrow
    arrABC(a) = Cells(a, 1) & Cells(a, 2) & Cells(a, 3)
Next a
For a = 2 To lrow
    arrUnic(a) = Cells(a, 1) & Cells(a, 2) & Cells(a, 3)
Next a
 
For i = LBound(arrABC) To UBound(arrABC)
        For Z = LBound(arrUnic) To i
            If arrUnic(Z) = arrABC(i) Then
                cnt = cnt + 1
                If cnt > 1 Then
                    Exit For
                End If
            End If
        Next Z
    If cnt = 1 Then
        Sheets("оптим").Activate
lrow2 = Cells(Cells.Rows.Count, 1).End(xlUp).Row
        Cells(lrow2 + 1, 1) = arrA(i)
        Cells(lrow2 + 1, 2) = arrB(i)
        Cells(lrow2 + 1, 3) = arrC(i)
        
For q = LBound(arrABC) To UBound(arrABC)
    If arrABC(q) = arrABC(i) Then
        summa = arrD(q) + summa
    End If
Next q
        Cells(lrow2 + 1, 4) = summa
    End If
cnt = 0
summa = 0
Sheets("исход").Activate
Next i
        
MsgBox Timer - qwerty
End Sub

Sub gggg()
  Dim row2Save&, cur&, s$, Dic As Object, Arr, i
  
  qwerty = Timer
  
    Set Dic = CreateObject("scripting.dictionary")
    Dic.comparemode = 1
    With Sheets("исход")
        Arr = .Range(.Cells(2, 1), .Cells(.Rows.Count, 4).End(xlUp)).Value
    End With
    
    For cur = 1 To UBound(Arr)
        s = Arr(cur, 1) & "|" & Arr(cur, 2) & "|" & Arr(cur, 3)
        If Dic.exists(s) Then
            i = Dic(s)
            Arr(i, 4) = Arr(i, 4) + Arr(cur, 4)
        Else
            row2Save = row2Save + 1
            If row2Save <> cur Then
                For i = 1 To 4
                    Arr(row2Save, i) = Arr(cur, i)
                Next
            End If
            Dic(s) = row2Save
        End If
    Next
    With Sheets("оптим")
        .UsedRange.Offset(1).Clear
        If row2Save Then .Cells(2, 1).Resize(row2Save, 4) = Arr
    End With
    
    MsgBox Timer - qwerty
    
    Set Dic = Nothing
End Sub