Skip to main content

AccessTr.neT


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

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

#43
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ı
Cevapla
#44
(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.
Cevapla
#45
(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"
.rar deneme_hy2.rar (Dosya Boyutu: 298,06 KB | İndirme Sayısı: 5)
Cevapla
#46
(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.
Cevapla
#47
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ğı
Cevapla
#48
(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]"
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task