(30/12/2020, 20:56)berduş yazdı:(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:
Dictionary 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"
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"
Denedim abey.Ado 1 saniye,Dictionary ise 6 saniye sürdü yaklaşık 128bin satır için.
Aslında dictionay ile alakalı durum değil döngü Listview için çalıştığı için.
Birde zaten Userforma veri gelmesi 33 saniye sürüyor
Bu arada elinize sağlık kod için.