Dim sarr As Variant, kq(), i, j, k As Long, dic As Object
sarr = [b3:G92].Value
ReDim kq(1 To UBound(sarr), 1 To UBound(sarr, 2))
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(sarr)
If Not IsEmpty(sarr(i, 4)) Then
If Not dic.Exists(sarr(i, 2) & sarr(i, 3)) Then
k = k + 1
dic.Add sarr(i, 2) & sarr(i, 3), k
For j = 1 To UBound(sarr, 2)
kq(k, j) = sarr(i, j)
Next j
Else
kq(dic.Item(sarr(i, 2) & sarr(i, 3)), 5) = kq(dic.Item(sarr(i, 2) & sarr(i, 3)), 5) + sarr(i, 5)
kq(dic.Item(sarr(i, 2) & sarr(i, 3)), 6) = kq(dic.Item(sarr(i, 2) & sarr(i, 3)), 6) + sarr(i, 6)
End If
End If
Next i
Sheet2.Cells.ClearContents
Sheet2.[b3].Resize(k, 6).Value = kq
Set dic = Nothing
Erase sarr
End Sub