AccessTr.neT

Bul · 30/12/2020, 17:05

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ı

Bul · 30/12/2020, 20:31

(30/12/2020, 17:05)berduş yazdı: 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ı

Böyle Array ile yapınca belki biraz uzun sürebilir lakin normal olarak dictionary ile yapılan bence sürmez abey.

Bul · 30/12/2020, 20:56

(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"

Bul · 30/12/2020, 23:27

(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:

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"

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 Img-grin

Bu arada elinize sağlık kod için.

Bul · 30/12/2020, 23:35

Hesaplamalar zaten userform yuklendikten sonra excele aktarma kodu içindi, form yuklenirken geçen 33 saniyeden sonrası için.
Ama burada ADO, DICTIONARY kıyaslaması yapmıyorum. zaten sorunun listviewden veri almaktan kaynaklandığının farkındayım. Burada tek vurguladığım tek tek listviewden veri almak yerine recordsetle almanın daha hızlı olacağı

Bul · 31/12/2020, 00:18

(30/12/2020, 23:35)berduş yazdı: Hesaplamalar zaten userform yuklendikten sonra excele aktarma kodu içindi, form yuklenirken geçen 33 saniyeden sonrası için.
Ama burada ADO, DICTIONARY kıyaslaması yapmıyorum. zaten sorunun listviewden veri almaktan kaynaklandığının farkındayım. Burada tek vurguladığım tek tek listviewden veri almak yerine recordsetle almanın daha hızlı olacağı

Order By kullanmadan alttaki gibide aynı sonuç veriyor abey.
Ado normalde daha pratik.

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]"

AccessTr.neT

Listviewden Excele Aktarımda Sumıf Kullanımı

Listviewden Excele Aktarımda Sumıf Kullanımı

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Giriş yap

Hesap oluştur

Konu Linkleri