31/12/2020, 18:16
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.
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