Birbirine Bağlı ListBox'lar

[bebar]

Merhaba,

UserForm'da iki listbox var,
ListBox1 için "s5.Range("L2:N" & Cells(Rows.Count, "L").End(3).Row).Value" hücre aralığında bulunan "L"sütünundaki benzersiz değerleri getirdim.
ListBox2 için ise listbox1'e gelen verilere tıkladığımda "K" sütununda karşılık gelen verileri benzersiz olarak getirmek istiyorum.
Aşağıdaki gibi kod yazdım fakat çalışmıyor.
yardımcı olursanız memnun olurum.

not: ListBox1 multiselect özelliği açıktır.

Private Sub ListBox1_Click()
Application.ScreenUpdating = False
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet
Dim s4 As Worksheet
Dim s5 As Worksheet
Set s1 = Sheets("Veri")
Set s2 = Sheets("list")
Set s3 = Sheets("Veri1")
Set s4 = Sheets("Veri2")
Set s5 = Sheets("Filtre")
Set dc1 = CreateObject("scripting.dictionary")
UserForm2.ListBox2.Clear
a = s5.Range("L2:N" & Cells(Rows.Count, "L").End(3).Row).Value

For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        For k = 1 To UBound(a)
            If ListBox1.List(i) = a(k, 1) Then
                krt = a(k, 2)
                If Not dc1.exists(krt) Then
                dc1(krt) = a(k, 2)
                UserForm2.ListBox2.AddItem a(k, 2)
                End If
            End If
        Next k
    End If
Next i

End Sub

 

[bebar]

merhaba,

daha iyi anlaşılması açısından örnek dosya ekledim.

teşekkürler.

 

[YUSUF44]

Aşağıdaki kodları dener misiniz?

Private Sub ListBox1_Change()
Application.ScreenUpdating = True
Dim s5 As Worksheet
Set s5 = Sheets("Sayfa1")
UserForm1.ListBox2.Clear
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        sorgu = "select distinct [URUNGRUBU] from[Sayfa1$] where [URUNKATEGORISI]='" & ListBox1.List(i) & "' "
        Set rs = con.Execute(sorgu)
        While Not rs.EOF
            ListBox2.AddItem rs("URUNGRUBU").Value
            rs.movenext
        Wend
    End If
Next i

End Sub

Private Sub UserForm_Initialize()
Application.ScreenUpdating = True
Dim s5 As Worksheet
Set s5 = Sheets("Sayfa1")
UserForm1.ListBox1.Clear
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select distinct [URUNKATEGORISI] from[Sayfa1$]"
Set rs = con.Execute(sorgu)
ListBox1.Column = rs.getrows
End Sub

 

[kemal turan]

Merhaba,
Yusuf Hocamın kodları tam istediğiniz gibi.
Bende biraz uğraşmıştım, boşa gitmesin ve farklı bir örnek olması açısından ekledim.
Selametle

 

[kemal turan]

merhaba,

daha iyi anlaşılması açısından örnek dosya ekledim.

teşekkürler

Merhaba,
Dosyanız anlaşılmasına anlaşıldı da;
Özellikle Yusuf hocamın kodları işinizi gördümü acaba ?
Nezaketen bir geri dönüş gerekmiyor mu ?

 

[yasarcan]

Merhaba,
Yusuf Hocamın kodları tam istediğiniz gibi.
Bende biraz uğraşmıştım, boşa gitmesin ve farklı bir örnek olması açısından ekledim.
Selametle

Selamlar
Bu uygulamada ListBox3 Multiselect olduğunu düşünün işaretli olduğunda sayfa 2 de d kolonunda (listboxa çektivi veri sırasıyla aynı satıra) "x" yazsın. işaret kaldırıldığında "" olsun. kaydedip çıkıldığında tekrar ListBox1-2-3 lere girildiğinde seçenekler önceden işaretliyse göstersin.
yapabilir miyiz?
not: başka bir arkadaşın uygulamsında yaptım ancak Yusuf hocamın çözdüğü örneğe aktaramadım.

 

[ÖmerFaruk]

Konular özü itibariyle benzer gibi gözükse de sonuçta hepsi Excel ve hepsi birbirine benziyor.

Sorunuzu yeni başlık altında sorarsanız, sorarken de kullandığınız Yusuf beyşn kodlarıyla yaptığınız haliyle örnek dosyanızı da eklerseniz hem daha çabuk cevap alır, hem de forum başka kullanıcıların aradığını bulabilmesi açısından daha verimli olur.

 

[yasarcan]

Tamamdır o zman detaylı anlatayım yeni sayfada.

 

[mekist]

@YUSUF44 Bey Merhaba

Sizin kodlarınızı kullanarak ekteki dosyayı yaptım
Karşılaştırma bölümünde aldığım veriler ilk satırı boş alıyor ve seçilebilir olarak getiriyor,
Sektörde olduğu gibi ilk satırdan itibaren yazdıramadım, kodun neresinde düzeltme yapmam gerekiyor

Private Sub UserForm_Initialize()
Application.ScreenUpdating = True
Dim s5 As Worksheet
Set s5 = Sheets("Hisseler")
ListBox1.Clear
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select distinct [Sektör] from[Hisseler$]"
Set rs = con.Execute(sorgu)
ListBox1.Column = rs.getrows
' Sektör bilgilerini ListBox1' e getirmek için

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
sorgu = "select distinct [Marj] from[Hisseler$]"
Set rs = con.Execute(sorgu)
ListBox5.Column = rs.getrows
' Marj bilgilerini ListBox5' e getirmek için

End Sub