Listbox Çoklu Süzme Hk.

[faruk59]

Merhabalar Userform üzerinde 1 ad listbox ve 2 ad textbox bulunmaktadır.Excel sayfasından Listboxa 45 sutunluk veri çekiyorum.Textboxtlara girdiğim değerlere göre ilgili sütünlarda arama yapmak istemekteyim.

Forumdan bulduğum kodlara göre Textbox 1 ve Textbox 2 içerisine yazdığım değere göre arama yaparken textbox 1 sonuçları doğru gelmekte fakat textbox 2 değerine veri girdiğimde sonuçlar kaybolup textbox 2 sonuçları gelmektedir.
Textbox 1 ve 2 içerisine yazılan verilere göre tek sonuç elde etmek için yardımlarınızı rica ederim.

Listboxa veriyi bu şekilde çekmekteyim.

Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 45 'sütun sayısı
ListBox1.RowSource = "A3:AS" & Cells(65536, "A").End(3).Row

End Sub

Textbox süzme işlemini bu şekilde yapmaktayım.

Private Sub TextBox16_Change()

Dim k As Range, a As Long, j As Byte, ilk_adres As String
ListBox1.RowSource = vbNullString
ReDim myarr(1 To 45, 1 To 1)
Set k = Range("b2:b65536").Find(TextBox16.Text & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
ilk_adres = k.Address
Do
a = a + 1
ReDim Preserve myarr(1 To 45, 1 To a)
For j = 0 To 44
myarr(j + 1, a) = k.Offset(0, j - 1).Value
Next j
Set k = Range("b2:b65536").FindNext(k)
Loop While k.Address <> ilk_adres And Not k Is Nothing
ListBox1.Column = myarr
End If
End Sub

 

[Orion1]

Textbox1 ve textbox2 demişsiniz.Ama kodunuzda textbox16 ya göre arama yapmışsınız.Diğer textbox ne olacak oda belli değil?

 

[faruk59]

Aslında textbox 1 textbox16 textbox2 textbox17 her iki textbox içinde ayni süz kodunu kullanmaktayim.

 

[Orion1]

Aslında textbox 1 textbox16 textbox2 textbox17 her iki textbox içinde ayni süz kodunu kullanmaktayim.

Peki textbox17 için hangi sütun sorgulanacak?Onu belirtmemişsiniz!
Ayrıca o sütun metinmi, sayımı?

 

[faruk59]

Textbox17 c2:c65536 araligini suzecek.Her iki veride metindir.

Ayni kodu kullandım derken sütun aralıklarını c2:c65536 seklinde degistirmistim.

 

[Orion1]

aşağıdaki prusedürü userforma yapıştırın.textbox16 ve textbox17 içinede aşağıdaki kodları girin.

Private Sub TextBox17_Change()
Call ara59
End Sub
Private Sub TextBox16_Change()
Call ara59
End Sub

Sub ara59()
Dim k As Range, a As Long, j As Byte, ilk_adres As String
ListBox1.RowSource = vbNullString
ReDim myarr(1 To 45, 1 To 1)
Set k = Range("b2:b65536").Find(TextBox16.Text & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
    ilk_adres = k.Address
    Do
        If k.Offset(0, 1).Value Like TextBox17.Value & "*" Then
            a = a + 1
            ReDim Preserve myarr(1 To 45, 1 To a)
            For j = 0 To 44
                myarr(j + 1, a) = k.Offset(0, j - 1).Value
            Next j
        End If
        Set k = Range("b2:b65536").FindNext(k)
    Loop While k.Address <> ilk_adres And Not k Is Nothing
    ListBox1.Column = myarr
End If
End Sub

 

[faruk59]

Çok tesekkur ederim sorunsuz çalışmaktadır.

 

[Orion1]

Çok tesekkur ederim sorunsuz çalışmaktadır.

Rica ederim.
İyi çalışmalar.

 

[yuemse]

aşağıdaki prusedürü userforma yapıştırın.textbox16 ve textbox17 içinede aşağıdaki kodları girin.

Private Sub TextBox17_Change()
Call ara59
End Sub
Private Sub TextBox16_Change()
Call ara59
End Sub

Sub ara59()
Dim k As Range, a As Long, j As Byte, ilk_adres As String
ListBox1.RowSource = vbNullString
ReDim myarr(1 To 45, 1 To 1)
Set k = Range("b2:b65536").Find(TextBox16.Text & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
    ilk_adres = k.Address
    Do
        If k.Offset(0, 1).Value Like TextBox17.Value & "*" Then
            a = a + 1
            ReDim Preserve myarr(1 To 45, 1 To a)
            For j = 0 To 44
                myarr(j + 1, a) = k.Offset(0, j - 1).Value
            Next j
        End If
        Set k = Range("b2:b65536").FindNext(k)
    Loop While k.Address <> ilk_adres And Not k Is Nothing
    ListBox1.Column = myarr
End If
End Sub

Kodu A ve B sütunlarına nasıl uygulayabilir