listbox ta detaylı arama

[ojibu]

bir telefon rehberi programında arama kısmına ; HALİL yazdığımda sadece HALİL ile başlayanları getiriyor. ama ben İBRAHİM HALİL dekini de getirsin istiyorum. yani sadece isim de değil orta isim yada soyisim de de varsa getirsin.Yardımcı olabilir misiniz.
kod şöyle;

Private Sub bultxt_Change()
Dim say, adet, miktar As Integer
Dim sonuc As String
Dim hucre, hcr As Range
bultxt = Evaluate("=UPPER(""" & bultxt & """)")
If OptionButton1.Value = True Then
If bultxt.Value = Empty Then
bultxt.SetFocus
Exit Sub
Else
Range(Range("I3"), Range("I" & Sayfa1.[A1].Value + 2)).ClearContents
say = Len(bultxt.Value)
sonuc = Left(bultxt.Value, say)
For Each hucre In Range(Range("B3"), Range("B" & Sayfa1.[A1].Value + 2))
If sonuc = Left(hucre, say) Then
hucre.Offset(0, 7).Value = hucre.Value
End If
Next
analist.Clear
For Each hcr In Range(Range("I3"), Range("I" & Sayfa1.[A1].Value + 2))
If hcr.Value <> "" Then analist.AddItem hcr
Next
Range(Range("I3"), Range("I" & Sayfa1.[A1].Value + 2)).Select
miktar = Application.CountA(Selection)
Label9.Caption = "Aranan kriterde " & miktar & " kayıt bulundu"
If miktar = 0 Then
MsgBox bultxt.Value & " ile başlayan kayıt bulunamadı.", vbInformation, "Telefon Rehberi"
analist.Clear
For Each hucre In Range(Range("B3"), Range("B" & Sayfa1.[A1].Value + 2))
If hucre.Value <> "" Then analist.AddItem hucre
Next hucre
Label9.Caption = "Telefon Rehberi Tüm İsim Listesi"
bultxt.SetFocus
End If
End If
End If
bultxt.SetFocus
End Sub

 

[PLİNT]

Merhaba
İstediğiniz sonucu aşağıdaki gibi değişiklikle alabilirsiniz verileriniz çok ise ve örnek dosya eklerseniz daha hızlı sonuç verecek kodlar yazılabilir gibi görünüyor.

[SIZE="2"]Private Sub bultxt_Change()
Dim say, adet, miktar As Integer
Dim sonuc As String
Dim hucre, hcr As Range
bultxt = Evaluate("=UPPER(""" & bultxt & """)")
If OptionButton1.Value = True Then
If bultxt.Value = Empty Then
bultxt.SetFocus
Exit Sub
Else
Range(Range("I3"), Range("I" & Sayfa1.[A1].Value + 2)).ClearContents
say = Len(bultxt.Value)
sonuc = Left(bultxt.Value, say)
For Each hucre In Range(Range("B3"), Range("B" & Sayfa1.[A1].Value + 2))
[COLOR="Red"]If hucre Like "*" & sonuc & "*" Then[/COLOR]
hucre.Offset(0, 7).Value = hucre.Value
End If
Next 
'....
'.......diğer kodlarınız
'...

[/SIZE]

 

[ojibu]

ilginize teşekkür ederim. ama hata verdi.

 

[ojibu]

https://drive.google.com/open?id=0B4qNx10-oHSzNHR2N3pQSlB5N2c dosya burada

 

[assenucler]

Sayın ijibu;



Günaydın.

Acaba, bizlerin de yararlanması için isimleri değiştirerek dosyayı eklemeniz mümkün mü?

Teşekkürler.

 

[PLİNT]

Ek dosyayı denermisiniz hata vermedi acaba değişkliği yanlış yeremi eklediniz?,
http://s4.dosya.tc/server4/b4ydxw/Telefon_Rehberi.zip.html

 

[assenucler]

Teşekkürler Sayın PLİNT.

 

[ojibu]

ilginize teşekkürler PLİNT. özelden mesaj attım

 

[PLİNT]

Merhaba
İstediğiniz aşağıdaki örnekteki gibi daha hızlı olacaktır.
http://s4.dosya.tc/server4/utnb58/Telefon_Rehberi2.zip.html

[SIZE="2"]Private Sub bultxt_Change()
Dim say, adet, miktar As Integer
On Error Resume Next
bultxt = Evaluate("=büyükharf(""" & bultxt & """)")
bultxt = Evaluate("=upper(""" & bultxt & """)")
Dim bul As Range
analist.Clear
Set bul = Range("b2:b65536").Find(bultxt & "*")
If Not bul Is Nothing Then
    fg = bul.Address
    Do
If LCase(bul) Like LCase("*" & bultxt & "*") Then
If bul.Row <> 2 Then
analist.AddItem Cells(bul.Row, "B").Value
End If
End If
 Set bul = Range("B2:B65536").FindNext(bul)
    Loop While Not bul Is Nothing And bul.Address <> fg
    Application.EnableEvents = True
End If
miktar = analist.ListCount
say = Cells(Rows.Count, 2).End(3).Row
If miktar = 0 Then
MsgBox bultxt.Value & " ile başlayan kayıt bulunamadı.", vbInformation, "Telefon Rehberi"
bultxt.Value = ""
End If
If miktar = say - 2 Then
Label9.Caption = "Telefon Rehberi Tüm İsim Listesi"
Else
Label9.Caption = "Aranan kriterde " & miktar & " kayıt bulundu"
End If
End Sub[/SIZE]