ListBox'a benzersiz veri alınması

xagox · 15 Nisan 2013

Merhabalar
Değerli forum üyeleri
Sorduğum konu ile alakalı benzer çalışmalar var fakat işin içindeki değişken sayısı artınca çözüm noktasındaki kodu maalesef uyarlayamıyorum...

Özet'le çalışma sayfasındaki belli bir aralıktan üç sütüna benzersiz ( tekrar eden veriler list boxta sadece 1 kez görünsün ) veri aktarımını sağlamaya çalışıyorum bir safha ilersinde de gelen verilerin bir sorgulamaya tabi olması gerekiyor 2. faz çok önemli değil esasında yapılırsa iyi olur. list boxta seçim yapıldığında da aşağıdaki textboxlara yine ilgili sayfadan veriler akacak ..

Yardım ve destekleriniz için çok teşekkürler

Sevgi ve Saygılarımla

Çalışma Dosyamı Ekliyorum...

suleyman242 · 15 Nisan 2013

http://www.excel.web.tr/f48/listboxtan-veri-silme-ve-arama-yapma-t72563.html
Benzerini bir arkadaş için yayınlamışlardı.

Orion1 · 15 Nisan 2013

Dosyanız ektedir.

Kod:

Option Base 1
Private Sub liste()
Dim z As Object, listem(), myarr(), n As Long, i As Long
listem = Range("C2:H" & Cells(Rows.Count, "C").End(xlUp).Row).Value
ReDim myarr(1 To 3, 1 To UBound(listem))
Set z = CreateObject("scripting.dictionary")
ListBox1.Clear
For i = 1 To UBound(listem)
    If listem(i, 1) <> "" And listem(i, 2) <> "" Then
        If CDate(listem(i, 4)) < CDate(listem(i, 6)) Then
            If Not z.exists(listem(i, 1) & listem(i, 2)) Then
                n = n + 1
                z.Add (listem(i, 1) & listem(i, 2)), n
                myarr(1, n) = listem(i, 1)
                myarr(2, n) = listem(i, 2)
                myarr(3, n) = listem(i, 6)
            End If
        End If
    End If
Next i
Erase listem
Set z = Nothing
If n > 0 Then
    ReDim Preserve myarr(3, n)
    ListBox1.List = Application.Transpose(myarr)
End If
End Sub

xagox · 16 Nisan 2013

Merhabalar
Sn Suleyman424 ilgili örnekte tekrarlanan veriler listboxt'a gözüküyor. Ben listboxtaki verilerin benzersiz olmasını istiyorum ama ilgi gösterdiğiniz için teşekkürler

Sn.Orion1 Ellerinize ve emeğinize sağlık ne kadar teşekkür etsem az. Bu forumdaki herkes adına saygılar sunarım

bebar · 30 Nisan 2019

Merhaba,
konu ihtiyacım olan bir konu aşağıdaki gibi bir kod oluşturdum fakat çalışmıyor.
K sütununda 19 satırdan itibaren benzersiz olan verileri listboxa getirmek istiyorum nerede hata yaptığımı söylerseniz memnun olurum.

Option Base 1
Private Sub liste()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet
Dim s4 As Worksheet
Dim wf As WorksheetFunction
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Set s3 = Sheets("Sayfa3")
Set s4 = Sheets("Sayfa4")

Dim z As Object, listem(), myarr(), n As Long, i As Long
listem = s1.Range("K19:K" & s1.Cells(Rows.Count, "K").End(xlUp).Row).Value
ReDim myarr(1 To UBound(listem))
Set z = CreateObject("scripting.dictionary")
ListBox2.Clear
For i = 19 To UBound(listem)
If listem(i, 11) <> "" Then
n = n + 1
z.Add listem(i, 11), n
myarr(1, n) = listem(i, 11)
End If
Next i
Erase listem
Set z = Nothing
If n > 0 Then
ReDim Preserve myarr(1, n)
ListBox2.List = Application.Transpose(myarr)
End If
End Sub

veyselemre · 30 Nisan 2019

Örnek eklememişsiniz ama,
Şöyle bir deneyin,

Kod:

Private Sub liste()
    lst = Sheets("Sayfa1").Range("K19:K" & Sheets("Sayfa1").Cells(Rows.Count, "K").End(xlUp).Row).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            If lst(i, 1) <> "" Then .Item(lst(i, 1)) = Null
        Next i
        ListBox2.List = .keys
    End With
End Sub

bebar · 30 Nisan 2019

teşekkür ederim hocam çok faydası oldu

AdemCan · 20 Aralık 2019

Merhaba
Sn veyselemre
Paylaşım için teşekkür ederim, öğrenmek için bir sorum olacaktı.
Bu kod ile bir sütundaki veriler benzersiz olarak ListBox'a alınıyor.

-A2:E aralığındaki verileri benzersiz şekilde yan yana, sütun başlıkları ile aldırmak istersek, kodda nasıl bir değişiklik yapılması gerekir?

lst = Sheets("Sayfa1").Range("A2:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value

veyselemre' Alıntı:
Private Sub liste() lst = Sheets("Sayfa1").Range("K19:K" & Sheets("Sayfa1").Cells(Rows.Count, "K").End(xlUp).Row).Value With CreateObject("Scripting.Dictionary") For i = 1 To UBound(lst) If lst(i, 1) <> "" Then .Item(lst(i, 1)) = Null Next i ListBox2.List = .keys End With End Sub

Korhan Ayhan · 20 Aralık 2019

Deneyiniz.

Kod:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
    ListBox1.Clear
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
    
    ReDim Veri(1 To UBound(Liste), 1 To 5)
    
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3) & "#" & Liste(X, 4) & "#" & Liste(X, 5)
            If Not .Exists(Aranan) Then
                .Add Aranan, Nothing
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
        
    ListBox1.ColumnCount = 5
    ListBox1.List = Veri
End Sub

AdemCan · 23 Aralık 2019

Merhaba Korhan Bey,
Paylaşım için teşekkür ederim.
Kod, sayfadaki bilgileri ListBox'a ekliyor ancak, benzersiz şekilde eklemedi, verileri olduğu gibi alıyor.
Örnek dosya ektedir. Yardımınız için teşekkür ederim.

Korhan Ayhan · 23 Aralık 2019

Üstte ki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

AdemCan · 24 Aralık 2019

Yardımınız teşekkür ederim. Kod hatasız çalışıyor.
Öğrenmek için kodları F8 ile adımladım ancak, eğer vaktiniz müsait olursa, kodların çalışma mantığını açıklamanız mümkün mü?

Korhan Ayhan · 24 Aralık 2019

Kod ile kısaca aşağıdaki işlemleri yapıyoruz.

--Listbox içeriğini temizliyoruz.
--LİSTE isimli değişkene sayfadaki A-E aralığındaki dolu hücrelerdeki verileri yüklüyoruz.
--Sonra VERİ isminde bir dizi oluşturuyoruz. Bu dizi sayfadaki veri satırı genişliğinde ve 5 sütundan oluşuyor.
--LİSTE değişkenine yüklediğimiz verileri döngüye alarak tek tek sorguluyoruz.
--Sorgulamada 5 sütundaki veriyi birleştirerek (ARANAN) işlem yapıyoruz.
--CreateObject("Scripting.Dictionary") nesnesini benzersiz kayıtları biriktirmek için kullanıyoruz. Çok hızlı bir nesnedir.
--Eğer sorgulanan veri benzersiz ise VERİ dizisine 5 sütun olarak yüklenmektedir.
--Döngülerin bitiminde VERİ dizisinde biriktirdiğimiz benzersiz listeyi ListBox nesnemize yüklüyoruz.

AdemCan · 27 Aralık 2019

Merhaba Korhan Bey, teşekkür ederim. Karışık geldi

ama biraz deneme yanılma ile zamanla halledebilirim sanırım

.
İyi çalışmalar dilerim.

tamer42 · 26 Mayıs 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

Kod:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
    ListBox1.Clear
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
   
    ReDim Veri(1 To UBound(Liste), 1 To 5)
   
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3) & "#" & Liste(X, 4) & "#" & Liste(X, 5)
            If Not .Exists(Aranan) Then
                .Add Aranan, Nothing
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
       
    ListBox1.ColumnCount = 5
    ListBox1.List = Veri
End Sub

Korhan hocam iyi bayramlar,
Burada benzersiz kayıtları Listbox' a alırken, satır da anladığım kadarıyla 5 sütunu (A, B, C, D, E) kontrol ediyor.

Kod:

Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3) & "#" & Liste(X, 4) & "#" & Liste(X, 5)

benim istediğim 3 sütunu kontrol etsin (A, B, C), bu üç sütundaki verilere göre benzersiz kayıtları belirlesin, yalnız ListBox' a yine 5 sütundaki verileri (A, B, C, D, E) getirsin.
(D, E) sütunudaki veriler aslında aynı fakat metinlerde ufak-tefek yazım farklılıkları olduğu için çok listeme yapıyor. onun için (D, E) sütununu benzersiz kriter belirlenmesinde devre dışı kalmasını istiyorum.

Teşekkürler, iyi günler.

Korhan Ayhan · 26 Mayıs 2020

@tamer42,

Bilmukabele.

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
    
    ListBox1.Clear
    
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
    
    ReDim Veri(1 To UBound(Liste), 1 To 5)
    
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
            If Not .Exists(Aranan) Then
                .Add Aranan, Nothing
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
        
    ListBox1.ColumnCount = 5
    ListBox1.List = Veri
End Sub

tamer42 · 26 Mayıs 2020

Korhan Ayhan' Alıntı:

@tamer42,

Bilmukabele.

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
   
    ListBox1.Clear
   
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
   
    ReDim Veri(1 To UBound(Liste), 1 To 5)
   
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
            If Not .Exists(Aranan) Then
                .Add Aranan, Nothing
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
       
    ListBox1.ColumnCount = 5
    ListBox1.List = Veri
End Sub

Çok teşekkürler Korhan Hocam
tekrar iyi bayramlar.

tamer42 · 27 Mayıs 2020

Korhan Ayhan' Alıntı:

@tamer42,

Bilmukabele.

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
   
    ListBox1.Clear
   
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
   
    ReDim Veri(1 To UBound(Liste), 1 To 5)
   
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
            If Not .Exists(Aranan) Then
                .Add Aranan, Nothing
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
       
    ListBox1.ColumnCount = 5
    ListBox1.List = Veri
End Sub

Korhan hocam günaydın,
Benzersiz kayıtlara ilave olarak 2. bir koşul daha getirebilir miyiz?
Örnek: A sütununda "a" ile başlayan yada A sütunda "Ali" olanları , özetle hem benzersiz olacak, hem de A sütununda "a" harfi ile başlayacak.

şimdiden teşekkürler,
iyi günler....

Korhan Ayhan · 27 Mayıs 2020

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
    
    ListBox1.Clear
    
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
    
    ReDim Veri(1 To UBound(Liste), 1 To 5)
    
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            If UCase(Left(Liste(X, 1), 1)) = "A" Then
                Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
                .Item(Aranan) = 1
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
        
    If Say > 0 Then
        ListBox1.ColumnCount = 5
        ListBox1.List = Veri
    End If
End Sub

tamer42 · 27 Mayıs 2020

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Private Sub CommandButton1_Click()
    Dim Liste As Variant, X As Long, Y As Byte, Aranan As String, Veri As Variant, Say As Long
   
    ListBox1.Clear
   
    Liste = Sheets("Sayfa1").Range("A1:E" & Sheets("Sayfa1").Cells(Rows.Count, "E").End(xlUp).Row).Value
   
    ReDim Veri(1 To UBound(Liste), 1 To 5)
   
    With CreateObject("Scripting.Dictionary")
        For X = 1 To UBound(Liste)
            If UCase(Left(Liste(X, 1), 1)) = "A" Then
                Aranan = Liste(X, 1) & "#" & Liste(X, 2) & "#" & Liste(X, 3)
                .Item(Aranan) = 1
                Say = Say + 1
                ReDim Preserve Veri(1 To UBound(Liste), 1 To 5)
                For Y = 1 To 5
                    Veri(Say, Y) = Liste(X, Y)
                Next
            End If
        Next
    End With
       
    If Say > 0 Then
        ListBox1.ColumnCount = 5
        ListBox1.List = Veri
    End If
End Sub

Çok teşekkür ederim Korhan Hocam

ListBox'a benzersiz veri alınması

xagox

Ekli dosyalar

suleyman242

Ekli dosyalar

Orion1

Uzman

Ekli dosyalar

xagox

bebar

veyselemre

Özel Üye

bebar

AdemCan

Altın Üye

Korhan Ayhan

Administrator

AdemCan

Altın Üye

Ekli dosyalar

Korhan Ayhan

Administrator

AdemCan

Altın Üye

Korhan Ayhan

Administrator

AdemCan

Altın Üye

tamer42

Destek Ekibi

Korhan Ayhan

Administrator

tamer42

Destek Ekibi

tamer42

Destek Ekibi

Korhan Ayhan

Administrator

tamer42

Destek Ekibi