düzeltilmiş son hali

t1 = Now

   Dim dic As Object

    Dim say As Long

    Dim i As Long, sonLitview As Long

    Dim kriter

    

    Set dic = CreateObject("Scripting.Dictionary")

    

    With ThisWorkbook.Sheets("sayfa1")

        With Me.ListView1

            sonLitview = .ListItems.Count

            If sonLitview = 0 Then GoTo var

            

            For i = 1 To sonLitview

                kriter = .ListItems(i).ListSubItems(1)

                

                If Not dic.Exists(kriter) Then

                   dic.Add kriter, Array(.ListItems(i).ListSubItems(2), .ListItems(i).ListSubItems(3), .ListItems(i).ListSubItems(4), .ListItems(i).ListSubItems(5))

                                  

                Else

                    dic(kriter) = Array(CStr(dic.Item(kriter)(0)), CStr(dic.Item(kriter)(1)), CDbl(dic.Item(kriter)(2)) + .ListItems(i).ListSubItems(4) * 1, CDbl(dic.Item(kriter)(3)) + .ListItems(i).ListSubItems(5) * 1)

                End If

            Next

        End With

            .Range("B1").Resize(dic.Count, 4) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.Items))

            .Range("A1").Resize(dic.Count, 1) = WorksheetFunction.Transpose(dic.keys)

    End With

    

'    For Each Key In dic

'        Debug.Print Key, dic(Key)(0), dic(Key)(1), dic(Key)(2), dic(Key)(3)

'    Next



var:

    On Error Resume Next

    Set dic = Nothing

t2 = Now

'Debug.Print "Dict", DateDiff("s", t1, t2)

MsgBox "Bitti"

sayın @kanakan52 kendi taktirinizdir bir şey diyemem ama denemelerimde 120 bin kayıtta ADO genelde 1-2 saniyede sonucu bulurken dictionary yönteminde süre 4-5 kat daha uzun çıktı