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 SubPrivate 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
