Re: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 31/12/2020
Berduş hocam kusura bakmazsanız son eklediğiniz kodları biraz değiştirdim.
Verdiğiniz dictionary eğer 65536 dan veri alırsa fazlasını getirmiyor transposeden dolayı.
X0000000000001,X0000000000002... gibi 100000 e kadar accesse eklerseniz dediğimi anlarsınız.
Denerseniz Kimlik alanındaki sayılarında tam sırasız geldiğini göreceksiniz abey.
Birde Kimlik ve Sipariş No alanını ters yapmışsınız.
Arşivimede bu şekilde aldım.
Private Sub BtnADO_Click()
Dim ADO_RS As Object, ADO_CN As Object
Const KacSutun As Integer = 6
With Sheets("Sayfa1")
.Range("A1").CurrentRegion.ClearContents
'____________________________________________
Set ADO_RS = CreateObject("ADODB.Recordset")
Set ADO_CN = CreateObject("ADODB.Connection")
Sql = "SELECT First(Kimlik) AS İlkKimlik,[Sipariş No], 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 First(Kimlik);"
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
.Range("A1").Resize(1, KacSutun) = Array("Kimlik", "Sipariş No", "Firma Adı", "Stok Adı", "Miktar", "Tutar")
.Range("A2").CopyFromRecordset ADO_RS 'excelde
.Range("A1").CurrentRegion.Columns.AutoFit
MsgBox "Bitti...", vbInformation, "Bitti"
son:
ADO_RS.Close
ADO_CN.Close
Set ADO_RS = Nothing
Set ADO_CN = Nothing
End With
End Sub
Private Sub BtnDictDnm_Click()
Dim dic As Object
Dim say As Long
Dim i As Long, sonLitview As Long
Dim kriter, arr()
Const KacSutun As Integer = 6
Set dic = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Sheets("Sayfa1")
.Range("A:F").ClearContents
With Me.ListView1
sonLitview = .ListItems.Count
If sonLitview = 0 Then GoTo var
ReDim arr(1 To sonLitview, 1 To KacSutun)
For i = 1 To sonLitview
kriter = .ListItems(i).SubItems(1)
If Not dic.Exists(kriter) Then
say = say + 1
dic.Add kriter, say
arr(say, 1) = .ListItems(i)
arr(say, 2) = .ListItems(i).SubItems(1)
arr(say, 3) = .ListItems(i).SubItems(2)
arr(say, 4) = .ListItems(i).SubItems(3)
End If
arr(dic(kriter), 5) = arr(dic(kriter), 5) + .ListItems(i).SubItems(4) + 0
arr(dic(kriter), 6) = arr(dic(kriter), 6) + .ListItems(i).SubItems(5) + 0
Next
End With
If say > 0 Then
.Range("A1").Resize(1, KacSutun) = Array("Kimlik", "Sipariþ No", "Firma Adý", "Stok Adý", "Miktar", "Tutar")
.Range("A2").Resize(say, KacSutun).Value = arr
.Range("A1").CurrentRegion.Columns.AutoFit
End If
End With
var:
On Error Resume Next
MsgBox "Bitti...", vbInformation, "Bitti"
Set dic = Nothing
Erase arr
End Sub
Re: Listviewden Excele Aktarımda Sumıf Kullanımı - berduş - 31/12/2020
https://resim.accesstr.net/do.php?img=10657
ADO Kodu:
Private Sub BtnADO_Click()
t1 = Now
Sheets("ADO").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("ADO").Range("A1").Resize(1, 6) = Array("Sipariş No", "Kimlik", "Firma Adı", "Stok Adı", "Miktar", "Tutar")
Sheets("ADO").Range("A2").CopyFromRecordset ADO_RS 'excelde
Sheets("ADO").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"
End Sub
Dictionary kodu Transpose çıkarıldı
Private Sub BtnDictDnm_Click()
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("Dict_hy")
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
Dim KeyDizi, ItemDizi, SonDizi
KeyDizi = dic.Keys
ItemDizi = dic.Items
ReDim SonDizi(LBound(KeyDizi) To UBound(KeyDizi), 0 To 5)
For i = LBound(KeyDizi) To UBound(KeyDizi)
SonDizi(i, 0) = KeyDizi(i)
SonDizi(i, 1) = ItemDizi(i)(0)
SonDizi(i, 2) = ItemDizi(i)(1)
SonDizi(i, 3) = ItemDizi(i)(2)
SonDizi(i, 4) = ItemDizi(i)(3)
SonDizi(i, 5) = ItemDizi(i)(4)
Next i
.Range("A2").Resize(UBound(SonDizi) + 1, 6) = SonDizi
.Range("A1").Resize(1, 6) = Array("Sipariş No", "Kimlik", "Firma Adı", "Stok Adı", "Miktar", "Tutar")
End With
var:
On Error Resume Next
Set dic = Nothing
Erase KeyDizi
Erase ItemDizi
Erase SonDizi
t2 = Now
Debug.Print "Dict_hy", DateDiff("s", t1, t2) & " saniye"
MsgBox DateDiff("s", t1, t2) & " saniye"
End Sub
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 31/12/2020
(31/12/2020, 22:01)berduş yazdı: ADO Kodu:
Private Sub BtnADO_Click()
t1 = Now
Sheets("ADO").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("ADO").Range("A1").Resize(1, 6) = Array("Sipariş No", "Kimlik", "Firma Adı", "Stok Adı", "Miktar", "Tutar")
Sheets("ADO").Range("A2").CopyFromRecordset ADO_RS 'excelde
Sheets("ADO").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"
End Sub
Dictionary kodu Transpose çıkarıldı
Private Sub BtnDictDnm_Click()
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("Dict_hy")
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
Dim KeyDizi, ItemDizi, SonDizi
KeyDizi = dic.Keys
ItemDizi = dic.Items
ReDim SonDizi(LBound(KeyDizi) To UBound(KeyDizi), 0 To 5)
For i = LBound(KeyDizi) To UBound(KeyDizi)
SonDizi(i, 0) = KeyDizi(i)
SonDizi(i, 1) = ItemDizi(i)(0)
SonDizi(i, 2) = ItemDizi(i)(1)
SonDizi(i, 3) = ItemDizi(i)(2)
SonDizi(i, 4) = ItemDizi(i)(3)
SonDizi(i, 5) = ItemDizi(i)(4)
Next i
.Range("A2").Resize(UBound(SonDizi) + 1, 6) = SonDizi
.Range("A1").Resize(1, 6) = Array("Sipariş No", "Kimlik", "Firma Adı", "Stok Adı", "Miktar", "Tutar")
End With
var:
On Error Resume Next
Set dic = Nothing
Erase KeyDizi
Erase ItemDizi
Erase SonDizi
t2 = Now
Debug.Print "Dict_hy", DateDiff("s", t1, t2) & " saniye"
MsgBox DateDiff("s", t1, t2) & " saniye"
End Sub
Son kodunuzda Dizi kullandınız
Benimkindede dizi ile 65536 sonrası geliyordu.
Birde Listview ile fazla uğaraşmıyordum bir hata buldum.
Kod:
.ListItems(i).ListSubItems(1)
değilde alttaki gibi kullanılıyormuş.Burda hata yok lakin başka yerde farkına vardım.Diğerleride aynı olacak.
Kod:
.ListItems(i).SubItems(1)
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - berduş - 31/12/2020
(31/12/2020, 22:12)feraz yazdı: Son kodunuzda Dizi kullandınız dizi kullanmaya karşı olsaydım dictionary de kullanmazdım)) sonuçta o da bir çeşit dizi sayılır
ama hala burada ADO kullanılmasının daha uygun olduğunu düşünüyorum
hem daha pratik hem daha hızlı
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - feraz - 31/12/2020
(31/12/2020, 22:18)berduş yazdı: (31/12/2020, 22:12)feraz yazdı: Son kodunuzda Dizi kullandınız dizi kullanmaya karşı olsaydım dictionary de kullanmazdım)) sonuçta o da bir çeşit dizi sayılır
ama hala burada ADO kullanılmasının daha uygun olduğunu düşünüyorum
hem daha pratik hem daha hızlı Abey gerçek dosyayı görsen Ado mu dersin Dizimi,dictionary mi bilmiyorum
Yani karışık durum.Biraz baktım kafa karıştı bağlantı ile.Çözsen çözsen yine srn çözen abey
RE: Listviewden Excele Aktarımda Sumıf Kullanımı - berduş - 31/12/2020
49. mesajdaki dosyanız sorunu çözmüyor mu ki?
|