textbox dan listboxda bulma

bilisim2010 · Çarşamba saat 18:07'de

merhaba aşağidaki formüller ile listboxa verimi çekiyorum ama ÇOK AĞIR ÇEKİYOR 9 dan fazlasını çekemiyorum hata veriyor vede textboxu silince listboxun içi boşalmıyor bu sorunu nasıl düzelebilirim?

Private Sub TextBox4_Change()
Dim i As Long, sat As Long, deg As String, x As Long
ListBox1.ColumnCount = 16
ListBox1.ColumnWidths = "50;150;50;50;150;50;60;60;60;60;60;60;60;60;60;60"
sat = Sheets("KAYİT").Cells(Rows.Count, "B").End(xlUp).Row
ListBox1.RowSource = ""
txtbx = UCase(Replace(Replace(TextBox4.Text, "i", "İ"), "ı", "I"))
For i = 1 To sat
deg = UCase(Replace(Replace(Cells(i, "B").Value, "i", "İ"), "ı", "I"))
If UCase(Replace(Replace(deg, "i", "İ"), "ı", "I")) Like "*" & txtbx & "*" Then
ListBox1.AddItem
ListBox1.List(SATIR, 0) = Cells(i, "A").Value
ListBox1.List(SATIR, 1) = Cells(i, "B").Value
ListBox1.List(SATIR, 2) = Cells(i, "C").Value
ListBox1.List(SATIR, 3) = Cells(i, "D").Value
ListBox1.List(SATIR, 4) = Cells(i, "E").Value
ListBox1.List(SATIR, 5) = Cells(i, "F").Value
ListBox1.List(SATIR, 6) = Cells(i, "G").Value
ListBox1.List(SATIR, 7) = Cells(i, "H").Value
ListBox1.List(SATIR, 8) = Cells(i, "I").Value
ListBox1.List(SATIR, 9) = Cells(i, "J").Value

ListBox1.List(SATIR, 10) = Cells(i, "K").Value
End If
Next i
End Sub

muhasebeciyiz · Dün 09:44 da

Private Sub TextBox4_Change()
Dim sat As Long
Dim deg As String
Dim txtbx As String
Dim rng As Range
Dim cell As Range

txtbx = UCase(Replace(Replace(TextBox4.Text, "i", "İ"), "ı", "I"))
ListBox1.Clear

sat = Sheets("KAYİT").Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Sheets("KAYİT").Range("B1:B" & sat)

For Each cell In rng
deg = UCase(Replace(Replace(cell.Value, "i", "İ"), "ı", "I"))

If deg Like "*" & txtbx & "*" Then
ListBox1.AddItem cell.Offset(0, -1).Value ' A sütunu
ListBox1.List(ListBox1.ListCount - 1, 1) = cell.Value ' B sütunu
ListBox1.List(ListBox1.ListCount - 1, 2) = cell.Offset(0, 1).Value ' C sütunu
ListBox1.List(ListBox1.ListCount - 1, 3) = cell.Offset(0, 2).Value ' D sütunu
ListBox1.List(ListBox1.ListCount - 1, 4) = cell.Offset(0, 3).Value ' E sütunu
ListBox1.List(ListBox1.ListCount - 1, 5) = cell.Offset(0, 4).Value ' F sütunu
ListBox1.List(ListBox1.ListCount - 1, 6) = cell.Offset(0, 5).Value ' G sütunu
ListBox1.List(ListBox1.ListCount - 1, 7) = cell.Offset(0, 6).Value ' H sütunu
ListBox1.List(ListBox1.ListCount - 1, 8) = cell.Offset(0, 7).Value ' I sütunu
ListBox1.List(ListBox1.ListCount - 1, 9) = cell.Offset(0, 8).Value ' J sütunu
ListBox1.List(ListBox1.ListCount - 1, 10) = cell.Offset(0, 9).Value ' K sütunu
End If
Next cell
End Sub

Deneyiniz

bilisim2010 · Dün 16:49 da

muhasebeciyiz' Alıntı:
Private Sub TextBox4_Change()
Dim sat As Long
Dim deg As String
Dim txtbx As String
Dim rng As Range
Dim cell As Range

txtbx = UCase(Replace(Replace(TextBox4.Text, "i", "İ"), "ı", "I"))
ListBox1.Clear

sat = Sheets("KAYİT").Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Sheets("KAYİT").Range("B1:B" & sat)

For Each cell In rng
deg = UCase(Replace(Replace(cell.Value, "i", "İ"), "ı", "I"))

If deg Like "*" & txtbx & "*" Then
ListBox1.AddItem cell.Offset(0, -1).Value ' A sütunu
ListBox1.List(ListBox1.ListCount - 1, 1) = cell.Value ' B sütunu
ListBox1.List(ListBox1.ListCount - 1, 2) = cell.Offset(0, 1).Value ' C sütunu
ListBox1.List(ListBox1.ListCount - 1, 3) = cell.Offset(0, 2).Value ' D sütunu
ListBox1.List(ListBox1.ListCount - 1, 4) = cell.Offset(0, 3).Value ' E sütunu
ListBox1.List(ListBox1.ListCount - 1, 5) = cell.Offset(0, 4).Value ' F sütunu
ListBox1.List(ListBox1.ListCount - 1, 6) = cell.Offset(0, 5).Value ' G sütunu
ListBox1.List(ListBox1.ListCount - 1, 7) = cell.Offset(0, 6).Value ' H sütunu
ListBox1.List(ListBox1.ListCount - 1, 8) = cell.Offset(0, 7).Value ' I sütunu
ListBox1.List(ListBox1.ListCount - 1, 9) = cell.Offset(0, 8).Value ' J sütunu
ListBox1.List(ListBox1.ListCount - 1, 10) = cell.Offset(0, 9).Value ' K sütunu
End If
Next cell
End Sub

Deneyiniz

HOCAM 10. DAN VAZGEÇTİM 9 BAŞLIK ALACAM AMA KASMASIN ÇOK KASIYOR ADD ITEM İLE BUNUN BAŞKA VERİ ÇEKME YÖNTEMİ YOKMU ACABA

Tasarım · Dün 16:54 da

Kod:

Bu bölüm kodun en başına yazılacak.
Dim WB As Workbook
Dim WS As Worksheet
Dim My_Connection As Object
Dim My_Recordset As Object
Dim My_Column As Integer
Dim My_Query As String
Dim X As Integer
Dim No As String

--------------------------------

Sub TCSorgula()
On Error Resume Next
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set My_Recordset = CreateObject("AdoDb.Recordset")
    My_Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                       WB.FullName & ";Extended Properties='Excel 12.0 Macro;Hdr=No'"
    My_Query = "Select * From [" & WS.Name & "$B2:C] Where F1 Like '%" & _
        UCase(Replace(Replace(txtTC.Value, "ı", "I"), "i", "İ")) & "%'"
    My_Recordset.Open My_Query, My_Connection, 1, 1
        If Not My_Recordset.EOF Then
'        txtTC.Value = "Kayıt bulunamadı!"
'        txtAdi.ForeColor = &HC07000
        ListeAna.RowSource = vbNullString
        ListeAna.Column = My_Recordset.GetRows
        ListeAna.ColumnCount = My_Recordset.Fields.Count
    End If
    My_Recordset.Close
    My_Connection.Close
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
End Sub
------------------------
Bu bölüm formun initialize bölümüne yazın.
Set WB = ThisWorkbook
Set WS = WB.Sheets("Veritabani")

@Korhan Ayhan hocamın yazdığı bu kodu ben kendi uygulamalarımda kullanıyorum ve oldukça hızlı bir şekilde filtreleme yapıyor.
Kodun ilgili bölümlerini kendinize göre uyarlamanız gerekir.

bilisim2010 · Dün 18:07 da

Tasarım' Alıntı:

Kod:

Bu bölüm kodun en başına yazılacak.
Dim WB As Workbook
Dim WS As Worksheet
Dim My_Connection As Object
Dim My_Recordset As Object
Dim My_Column As Integer
Dim My_Query As String
Dim X As Integer
Dim No As String

--------------------------------

Sub TCSorgula()
On Error Resume Next
    Set My_Connection = CreateObject("AdoDb.Connection")
    Set My_Recordset = CreateObject("AdoDb.Recordset")
    My_Connection.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
                       WB.FullName & ";Extended Properties='Excel 12.0 Macro;Hdr=No'"
    My_Query = "Select * From [" & WS.Name & "$B2:C] Where F1 Like '%" & _
        UCase(Replace(Replace(txtTC.Value, "ı", "I"), "i", "İ")) & "%'"
    My_Recordset.Open My_Query, My_Connection, 1, 1
        If Not My_Recordset.EOF Then
'        txtTC.Value = "Kayıt bulunamadı!"
'        txtAdi.ForeColor = &HC07000
        ListeAna.RowSource = vbNullString
        ListeAna.Column = My_Recordset.GetRows
        ListeAna.ColumnCount = My_Recordset.Fields.Count
    End If
    My_Recordset.Close
    My_Connection.Close
    Set My_Recordset = Nothing
    Set My_Connection = Nothing
End Sub
------------------------
Bu bölüm formun initialize bölümüne yazın.
Set WB = ThisWorkbook
Set WS = WB.Sheets("Veritabani")

@Korhan Ayhan hocamın yazdığı bu kodu ben kendi uygulamalarımda kullanıyorum ve oldukça hızlı bir şekilde filtreleme yapıyor.
Kodun ilgili bölümlerini kendinize göre uyarlamanız gerekir.

MERHABA BEN office365 kullanıyorum sanırım bu kodlar benim excel e uymuyor hocam uyarladım çalışmıyor zaten teşekkürler. bunun office365 e uyumlu olanı olsaydı denerdim.

Tasarım · Dün 21:17 da

bilisim2010' Alıntı:
MERHABA BEN office365 kullanıyorum sanırım bu kodlar benim excel e uymuyor hocam uyarladım çalışmıyor zaten teşekkürler. bunun office365 e uyumlu olanı olsaydı denerdim.

Örnek bir dosya paylaşırsanız sizin kodlarınıza buna uyarlayabilirim.

bilisim2010 · Bugün 00:28

Tasarım' Alıntı:
Örnek bir dosya paylaşırsanız sizin kodlarınıza buna uyarlayabilirim.

HOCAM BEN SORUNU ÇÖZDÜM GEREK KALMADI TEŞEKKÜRLER. İHTİYACI OLAN OLURSA AŞAĞIDAKİ KODLAR İLE HIZLICA 1500 -2000 VERİYİ ÇEKEBİLİYORSUNUZ BENDE BAŞKASINDAN ALINTI YAPTIM HAZIRLAYANDAN ALLAH RAZI OLSUN

Private Sub TextBox1_Change()
Dim Son As Long, Veri As Variant, X As Long

Son = WorksheetFunction.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)
Veri = S1.Range("A2:Q" & Son).Value

lstpersonel.Clear

ReDim Liste(1 To 16, 1 To 1)

For X = LBound(Veri, 1) To UBound(Veri, 1)
If UCase(Replace(Replace(Veri(X, 2), "ı", "I"), "i", "İ")) Like "*" & _
UCase(Replace(Replace(TextBox1, "ı", "I"), "i", "İ")) & "*" Then
Say = Say + 1
ReDim Preserve Liste(1 To 16, 1 To Say)
For y = 1 To 16
Liste(y, Say) = Veri(X, y)
Next
End If
Next

If Say > 0 Then
With lstpersonel
.ColumnCount = 16
.Column = Liste
.AddItem , 0
For X = 1 To 16
.List(0, X - 1) = S1.Cells(1, X).Value
Next
.ListIndex = 0
End With

TextBox1.BackColor = &H80000005
TextBox1.ForeColor = &H80000008
Else
TextBox1.BackColor = vbRed
TextBox1.ForeColor = vbWhite
End If

Erase Veri
Erase Liste

End Sub

Private Sub UserForm_Initialize()
Set S1 = Sheets("KAYİT")
With Me.lstpersonel
.ColumnCount = 17
lstpersonel.ColumnWidths = "50;150;50;50;230;50;50;50;50;50;50;50;50;50;50;50"

.List = S1.Range("A2:Q" & S1.Cells(S1.Rows.Count, 1).End(3).Row).Value
.AddItem , 0
For X = 1 To 17
.List(0, X - 1) = S1.Cells(1, X).Value
Next
.ListIndex = 0
End With
End Sub

Tasarım · Bugün 09:43

Ben yukarıdaki kod ile yedi, sekiz bin veri arasında çok hızlı bir şekilde filtreleme yapabiliyorum. Sonra yine ihtiyacınız olursa yardımcı olurum.

bilisim2010 · Bugün 10:22

Tasarım' Alıntı:
Ben yukarıdaki kod ile yedi, sekiz bin veri arasında çok hızlı bir şekilde filtreleme yapabiliyorum. Sonra yine ihtiyacınız olursa yardımcı olurum.

hocam çok teşekkür ederim ama benim şuan farklı bir konuda yardıma ihtiyacım var kısaca özetleyeyim dosyayıda göndereyim bir bakıverin lütfen

textbox ile aratıyorum listbox ile buluyorum seçtiğimi userformdaki textboxlarıma yerleştiriyorum buraya kadar okey. ancak bir sil butonuyla seçtiğimi silmiyor gidip sayfadaki ilk satırda kim varsa onu siliyor. ama arama yapmadan listeden seçsem doğrusunu siliyor. burada çok tıkandım hocam. bir bakarsanız nasıl yaparız size zahmet.

İBOSOFT.xlsm

drive.google.com