- Katılım
- 20 Haziran 2008
- Mesajlar
- 697
- Excel Vers. ve Dili
- Microsoft Office ev ve iş 2019
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Private Sub TextBox1_Change()
Dim k As Range, adrs As String, sat As Long
Dim sh As Worksheet, myarr(), j As Long
ListBox1.Clear
ReDim myarr(1 To 5, 1 To 65536)
Set sh = Sheets("DATA")
sat = sh.Cells(65536, "B").End(xlUp).Row
If sat < 2 Then Set sh = Nothing: Exit Sub
Set k = sh.Range("B2:B" & sat).Find(TextBox1.Text & "*", , xlValues, xlWhole, , , MatchCase:=True)
If Not k Is Nothing Then
adrs = k.Address
Do
j = j + 1
myarr(1, j) = k.Offset(0, -1)
myarr(2, j) = k.Value
myarr(3, j) = k.Offset(0, 1)
myarr(4, j) = k.Offset(0, 2)
myarr(5, j) = k.Offset(0, 3)
Set k = sh.Range("B2:B" & sat).FindNext(k)
Loop While Not k Is Nothing And k.Address <> adrs
ReDim Preserve myarr(1 To 5, 1 To j)
ListBox1.Column = myarr
Erase myarr
End If
Set k = Nothing
Set sh = Nothing
End Sub
Dosyanız ektedir.
Kod:Private Sub TextBox1_Change() Dim k As Range, adrs As String, sat As Long Dim sh As Worksheet, myarr(), j As Long ListBox1.Clear ReDim myarr(1 To 5, 1 To 65536) Set sh = Sheets("DATA") sat = sh.Cells(65536, "B").End(xlUp).Row If sat < 2 Then Set sh = Nothing: Exit Sub Set k = sh.Range("B2:B" & sat).Find(TextBox1.Text & "*", , xlValues, xlWhole, , , MatchCase:=True) If Not k Is Nothing Then adrs = k.Address Do j = j + 1 myarr(1, j) = k.Offset(0, -1) myarr(2, j) = k.Value myarr(3, j) = k.Offset(0, 1) myarr(4, j) = k.Offset(0, 2) myarr(5, j) = k.Offset(0, 3) Set k = sh.Range("B2:B" & sat).FindNext(k) Loop While Not k Is Nothing And k.Address <> adrs ReDim Preserve myarr(1 To 5, 1 To j) ListBox1.Column = myarr Erase myarr End If Set k = Nothing Set sh = Nothing End Sub
hocam örneklemiş olduğunuz bu kodlar için çook teşekkür ederim sizin bu kodlarınız sayesinde deneme yanılma yöntemi ile birşeyler yapmaya çalışıyoruz. dimağınız açık, gözleriniz ferli, sıhhatiniz daim olsun.
Estafurullah.Evren Bey;
Her zamanki gibi yardımlarınız için çook teşekkür ederim.Sağolun
Şunu iyi hatırlıyorum bu siteye ilk üye olduğumda yine ilk dosyama yine siz yardımcı olmuştunuz.
Yani bir bakıma sizin sayenizde excelimi bir yerlere kadar ilerletmiş oldum.
bunun için size ayrıyeten minnettarım.Hayırlı forumlar..
bunun gibi ben belirleyebilirmiyim aralıklarıListBox1.ColumnWidths = "60;65;180;100;80;40;"
Evren bey çok olmazsam eğer bir şey daha rica edebilirmiyim
Listboxımıza bütün müşterilerin listelenmesini sağlayabilirmiyiz .(arama yapmadan)
Şöyleki diyelim a harfiyle başlıyan müşteri listem en başta olacağından o firmayı aratmama gerek kalmıyacak listeden duble clik ile en üste a harfi ile olanlar yer alacağından hemen listeden seçebileyim.
ikinci bir isteğim ise list boxta müşteri no adı soyadı arası,v.d adı.v.d no çok açık bu arayı yakınlaştırabilirmiyiz.
bunun gibi ben belirleyebilirmiyim aralıkları
Günaydın evren BeyDosyayı güncelledim.
2 numaralı mesajdan indirebiliersiniz.![]()