Buda veri çoksa hızlı çalışması gerek.

Sub Etopla()

    Dim dic As Object

    Dim say As Long

    Dim i As Long

    Dim kriter, arr(), dizi

    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

        dizi = .Range("A2:F" & sonSatir).Value

        ReDim arr(1 To sonSatir, 1 To 6)

        For i = 1 To UBound(dizi)

            kriter = CStr(dizi(i, 2))

            If Not dic.Exists(kriter) Then

                say = say + 1

                dic.Add kriter, say

                arr(say, 1) = dizi(i, 1)

                arr(say, 2) = dizi(i, 2)

                arr(say, 3) = dizi(i, 3)

                arr(say, 4) = dizi(i, 4)

            End If

            arr(dic(kriter), 5) = arr(dic(kriter), 5) + dizi(i, 5) + 0

            arr(dic(kriter), 6) = arr(dic(kriter), 6) + dizi(i, 6) + 0

        Next

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

    End With

var:

    On Error Resume Next

    MsgBox "bitti"

    Set dic = Nothing

    Erase arr: Erase dizi

End Sub