Sonuç J:O aralığına gelir.Gerekärse ADO ilede yapılabilir.

Sub Etopla()



    Dim dic As Object

    Dim  say As Long

    Dim i As Long

    Dim kriter, arr()

    Dim sonSatir As Long

    

    Set dic = CreateObject("Scripting.Dictionary")

    

    With ThisWorkbook.Sheets("Sheet1")

        sonSatir = .Cells(Rows.Count, 1).End(3).Row

        .Range("J2:O" & Rows.Count).ClearContents

        If sonSatir < 2 Then GoTo var

        ReDim arr(1 To sonSatir, 1 To 6)

        

        For i = 2 To sonSatir

            kriter = .Cells(i, 2).Value

            If Not dic.Exists(kriter) Then

                say = say + 1

                dic.Add kriter, say

                arr(say, 1) = .Cells(i, 1).Value

                arr(say, 2) = .Cells(i, 2).Value

                arr(say, 3) = .Cells(i, 3).Value

                arr(say, 4) = .Cells(i, 4).Value

            End If

            arr(dic(kriter), 5) = arr(dic(kriter), 5) + .Cells(i, 5).Value

            arr(dic(kriter), 6) = arr(dic(kriter), 6) + .Cells(i, 6).Value

        Next

        If say > 0 Then .Range("J2").Resize(say, 6).Value = arr

    End With

var:

    MsgBox "bitti"

    Set dic = Nothing

    Erase arr

End Sub