(30/12/2020, 20:31)feraz yazdı: Böyle Array ile yapınca belki biraz uzun sürebilir lakin normal olarak dictionary ile yapılan bence sürmez abey.

dictionaryle ilgili çok deneyimim yok
ekleyebilirseniz sevinirim
referanslara hem ADO hem de Scripting Runtime eklenmiştir
ADO Kodu:

t1 = Now

Sheets("sayfa2").Cells.Clear

'____________________________________________

Set ADO_RS = New ADODB.Recordset

Set ADO_CN = New ADODB.Connection



Sql = "SELECT [Sipariş No], First(Kimlik) AS İlkKimlik, First([Firma Adı]) AS [İlkFirma Adı], First([Stok Adı]) AS [İlkStok Adı], " & _

      "Sum(Miktar) AS ToplaMiktar, Sum(Tutar) AS ToplaTutar " & _

      "FROM deneme " & _

      "GROUP BY [Sipariş No] " & _

      "ORDER BY [Sipariş No], First(Kimlik), First([Firma Adı]), First([Stok Adı]);"



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.Path & "\deneme.accdb"

ADO_CN.Open

ADO_RS.Open Sql, ADO_CN, 3, 1

'

'  Eğer Hiç Kayıt Yoksa

If ADO_RS.RecordCount = 0 Then

    MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

    GoTo son

End If

ADO_RS.MoveLast

ADO_RS.MoveFirst



Sheets("sayfa2").Range("A1").Resize(1, 6) = Array("Kimlik", "Sipariş No", "Firma Adı", "Stok Adı", "Miktar", "Tutar")

Sheets("sayfa2").Range("A2").CopyFromRecordset ADO_RS 'excelde

Sheets("sayfa2").Columns("A:f").AutoFit



son:

ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing



t2 = Now

Debug.Print "ADO", DateDiff("s", t1, t2) & " saniye"

MsgBox DateDiff("s", t1, t2) & " saniye"

Dictionary Kodu:

t1 = Now



    Dim say As Long

    Dim i As Long, sonLitview As Long

    Dim kriter

    

    

    Dim dic As Scripting.Dictionary

    Set dic = New 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), .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)), CStr(dic.Item(kriter)(2)), CDbl(dic.Item(kriter)(3)) + .ListItems(i).ListSubItems(4) * 1, CDbl(dic.Item(kriter)(4)) + .ListItems(i).ListSubItems(5) * 1)

                End If

            Next

        End With

            .Cells.Clear

            .Range("A1").Resize(1, 6) = Array("Kimlik", "Sipariş No", "Firma Adı", "Stok Adı", "Miktar", "Tutar")

            .Range("B2").Resize(dic.Count, 5) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(dic.Items))

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

    End With

var:

    On Error Resume Next

    Set dic = Nothing

t2 = Now

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

MsgBox DateDiff("s", t1, t2) & " saniye"