Listbox Yardımı

[celik_fatih]

Merhaba,

Oluşturmuş olduğum userform içerisinde 3 adet listbox ile kriterlere göre filtreleme yapmaktayım. Ancak bunu daha fazla kritere göre yapmak için kodlarda nasıl bir değişiklik yapmam gerekiyor anlayamadım.
yardımlarınızı rica ederim.

Dim f, NbCol, NomTableau, TblBD()
Private Sub UserForm_Initialize()
NomTableau = "Tableau1"
TblBD = Range(NomTableau).Value
NbCol = UBound(TblBD, 2)
Set d = CreateObject("scripting.dictionary")
For i = LBound(TblBD) To UBound(TblBD)
d(TblBD(i, 3)) = ""
Next i
Me.ChoixListBox1.List = d.keys
Set d = CreateObject("scripting.dictionary")
For i = LBound(TblBD) To UBound(TblBD)
d(TblBD(i, 5)) = ""
Next i
Me.ChoixListBox2.List = d.keys
Set d = CreateObject("scripting.dictionary")
For i = LBound(TblBD) To UBound(TblBD)
d(TblBD(i, 6)) = ""
Next i
Me.ChoixListBox3.List = d.keys
Me.ListBox1.ColumnCount = NbCol
Affiche
EnteteListBox
End Sub

Sub EnteteListBox()
X = Me.ListBox1.Left + 8
Y = Me.ListBox1.Top - 20
For c = 1 To NbCol
Set Lab = Me.Controls.Add("Forms.Label.1")
Lab.Caption = Range(NomTableau).Offset(-1).Item(1, c)
Lab.ForeColor = vbBlack
Lab.Top = Y
Lab.Left = X
Lab.Height = 24
Lab.Width = Range(NomTableau).Columns(c).Width * 1#
X = X + Range(NomTableau).Columns(c).Width * 1
tempcol = tempcol & Range(NomTableau).Columns(c).Width * 1# & ";"
Next c
tempcol = tempcol
On Error Resume Next
Me.ListBox1.ColumnWidths = tempcol
On Error GoTo 0
End Sub
Private Sub ChoixListBox1_change()
Affiche
End Sub
Private Sub ChoixListBox2_change()
Affiche
End Sub
Private Sub ChoixListBox3_change()
Affiche
End Sub
Sub Affiche()
Dim Liste(), ok(1 To 20)
n = 0
For i = LBound(TblBD) To UBound(TblBD)
For o = 1 To 20: ok(o) = False: Next o
p = 0
For Each c In Array(3, 5, 6)
p = p + 1
s = 0
For j = 0 To Me("ChoixListBox" & p).ListCount - 1
If Me("ChoixListBox" & p).Selected(j) Then s = s + 1
Next j
If s = 0 Then
ok(p) = True
Else
For j = 0 To Me("ChoixListBox" & p).ListCount - 1
If Me("ChoixListBox" & p).Selected(j) Then
If TblBD(i, c) = Me("ChoixListBox" & p).List(j) Then ok(p) = True
End If
Next j
End If
Next c
If ok(1) And ok(2) And ok(3) Then
n = n + 1
ReDim Preserve Liste(1 To NbCol, 1 To n)
For k = 1 To NbCol
Liste(k, n) = TblBD(i, k)
Next k
End If
Next i
If n > 0 Then Me.ListBox1.Column = Liste Else Me.ListBox1.Clear
End Sub

 

[turist]

Ekli dosyayı kontrol edin.

 

[Korhan Ayhan]

Veri sayısı 10.000'lere ulaşınca aşırı yavaş çalışıyor...

 

[turist]

Veri sayısı 10.000'lere ulaşınca aşırı yavaş çalışıyor...

Korhan Bey, merhaba.
Bahis konusu Userform Filtreleme mi?

 

[Korhan Ayhan]

Evet..

 

[turist]

Sayın @Korhan Ayhan ,

10.000 veri dışında , soruyu soran üyenin dosyasını ve verilen cevabı test ettiniz mi?
Sorulan soruya verilen cevap uygun olmuş mu?
Değerli görüşlerinizi bildirirseniz, üyelerimiz faydalanır.
Not:
Anlaşılacağı gibi, sayın @celik_fatih yabancı bir kaynaktan aldığı kod üzerine "Filtreleme" sorunu için soru sormuştu.Verilerin sayısı hakkında ne bir bilgi vermiş ne de istekte bulunmuştu.
Filtreleme kodu zaten birden fazla kriter için düzenlenmiş durumda.
Ekte yer alan xls,xlsm ve xlsb şeklinde 11.000 satırlık 3 dosyanın incelemesini de yapabilirsiniz.

 

[Korhan Ayhan]

Az satırlı verilerde bu tip kodlamadan faydalanılabilir.

Çok satırlı verilerde performans için farklı alternatifler üretmek gerekiyor. Daha önce benzer konuların işlendiğini hatırlıyorum. Arama yapılırsa linklere ulaşılabilinir.

 

[turist]

Sağolun.

 

[celik_fatih]

Hocam merhaba
Öncelik olarak ilginize teşekkür ederim. 6 adet ChoixListBox oluşturup 6 sütünüda filtrelemeye çalıştım ancak olmadı. edinmiş olduğum kaynakta satır sayısı çok fazla ben onu gözden kaçırdım. benim kullanacağım tabloda liste bu kadar uzun olmayacak. dolayısı ile çok fazla kasmayacak diye düşünüyorum.

Sayın @Korhan Ayhan ,

10.000 veri dışında , soruyu soran üyenin dosyasını ve verilen cevabı test ettiniz mi?
Sorulan soruya verilen cevap uygun olmuş mu?
Değerli görüşlerinizi bildirirseniz, üyelerimiz faydalanır.
Not:
Anlaşılacağı gibi, sayın @celik_fatih yabancı bir kaynaktan aldığı kod üzerine "Filtreleme" sorunu için soru sormuştu.Verilerin sayısı hakkında ne bir bilgi vermiş ne de istekte bulunmuştu.
Filtreleme kodu zaten birden fazla kriter için düzenlenmiş durumda.
Ekte yer alan xls,xlsm ve xlsb şeklinde 11.000 satırlık 3 dosyanın incelemesini de yapabilirsiniz.

 

[turist]

İyi çalışmalar.