Bir örnek dosya ekledim açıklamalar var kodda yinede açıklayayım.
Bu dosyanın konu ile alakası yok sadece örnek.
Eğer dosyanın ilk açılışında hata gelirde dict ile alakası yok çalışıyor.
Mantık şu.
Veriler kapalı excelden geliyor.
If Not scr.Exists(rs(0).Value) Then ' Eger dictionary icinde rs(0).Value bu deger yoksa
say = say + 1
scr.Add rs(0).Value, say 'Burda say demek item i,rs(0).Value ise key dir
End If
yukarıdaki kod dict in içine benzersiz veri alıyor bir kez içine.Eğer mükerrer veri olsaydı hata olurdu bu yüzden If Not scr.Exists(rs(0).Value) Then ile aynı veri yoksa koşulu eklendi.
scr(rs(0).Value) = scr(rs(0).Value)
bu kısımda aynısı if koşuluna gerek yok burda.Fakat item değil key e veriler gelir.
yukarıdaki koddaki scr.Add rs(0).Value, say burda say item dir.
scr(rs(0).Value) = scr(rs(0).Value) ile scr.Add rs(0).Value , "" aynıdır aslında
alttaki kodlar ise join ile topluca mesaj kutusunda listeleniyor.
MsgBox "Dictionary keyler:" & vbNewLine & Join(scr.Keys, vbNewLine)
MsgBox "Dictionary itemler:" & vbNewLine & Join(scr.Items, vbNewLine)
MsgBox "Dictionary satir sayisi:" & vbNewLine & scr.Count
Alttaki ise kezlerin içinde döngü kurdum immediate window ile sonucu incelersiniz yada additem ile combo yada listboxa çekersiniz.
' For Each xx In scr.Keys'Alttaki ile ayni
' Debug.Print xx
' Next
Alttakide normal döngü ile aynısı.
For i = 0 To scr.Count - 1 '0 dan baslar
Debug.Print scr.Keys()(i)
Next
Alttaki ilede listboxa toplu veri aktarma.
Me.lstbox1.RowSource = ""
Me.lstbox1.RowSource = Join(scr.Keys, ";") 'Listboxa veri aliniyor toptan
Me.lstbox2.RowSource = ""
Me.lstbox2.RowSource = Join(scr.Items, ";") 'Listboxa veri aliniyor toptan
Normalde excelde topluca hücrelere veri aktarma mesela range("A1").resize(scr.count,1).value=application.transpose(scr.keys) ile aktarılıyor belki yanlış yazmış olabilirim kafadan yazdım.Access te transpose göremedim.
Kodları F8 ile adım adım inceleyebilirsiniz watch vindow ilede takip edebilirsiniz.Özetle böyle.
Excledeki B sütunundaki verilerin benzersiz listelendiğini söyleyeyim.
Kodların tamamı.
Option Compare Database
Private Sub Komut0_Click()
Dim say As Long, say1 As Long
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sSql As String
Dim txtDosyaAdres As String
Dim scr As Object
Set scr = CreateObject("Scripting.Dictionary")
txtDosyaAdres = CurrentProject.Path & "\veri.xlsx"
sSql = "select [KOD],[AD],[YAÞ] from [Sayfa1$B3:E] where [KOD] Is Not Null" '
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & txtDosyaAdres & ";extended properties=""excel 12.0;hdr=Yes;imex=1"""
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.CursorType = adOpenKeyset
rs.LockType = adLockOptimistic
rs.Open sSql, con
Do While Not rs.EOF And Not rs.BOF 'Tablo güncelleme icin(Exceldeki recordseti icine alinan veriler icin döngü)
'--------------------------------------------------------------------------------------------------------------------------------
If Not scr.Exists(rs(0).Value) Then ' Eger dictionary icinde rs(0).Value bu deger yoksa
say = say + 1
scr.Add rs(0).Value, say 'Burda say demek item i,rs(0).Value ise key dir
End If
'Üst ve alt ayni
' scr(rs(0).Value) = scr(rs(0).Value) 'Burasi benzersiz veri alir.Bazen .value eklenmezse hata verir o yüzden .value eklendi
'--------------------------------------------------------------------------------------------------------------------------------
rs.MoveNext
Loop
MsgBox "Dictionary keyler:" & vbNewLine & Join(scr.Keys, vbNewLine)
MsgBox "Dictionary itemler:" & vbNewLine & Join(scr.Items, vbNewLine)
MsgBox "Dictionary satir sayisi:" & vbNewLine & scr.Count
'///////////////////////////////////////////////////////////////////
' For Each xx In scr.Keys'Alttaki ile ayni
' Debug.Print xx
' Next
For i = 0 To scr.Count - 1 '0 dan baslar
Debug.Print scr.Keys()(i)
Next
'///////////////////////////////////////////////////////////////////
Me.lstbox1.RowSource = ""
Me.lstbox1.RowSource = Join(scr.Keys, ";") 'Listboxa veri aliniyor toptan
Me.lstbox2.RowSource = ""
Me.lstbox2.RowSource = Join(scr.Items, ";") 'Listboxa veri aliniyor toptan
rs.Close
con.Close
Set rs = Nothing
Set scr = Nothing
End Sub