Textbox (Suche) mit mehreren Wörtern und ausgabe in Listbox

Hallo Profis,

ich suche eine Möglichkeit eine Tabelle möglichst schnell mit mehreren Wörtern zu durchsuchen.

Es gibt ein USERFORM mit einer Textbox und einer Listbox zur Ergebnisanzeige.
Das Beispiel ist mal hier:
https://www.herber.de/bbs/user/162606.xlsm

Aktuell kann ich schon suchen, aber leider müssen die Daten genau eingegeben werden.

So stehen die Daten z.B. in der Tabelle
Brunnengasse im Ortsteil Buch am Ahorn
Brunnenstraße im Ortsteil Schillingstadt

Jetzt möchte ich gern in der Textbox "Brun" und "Aho" eingeben und in der Listbox soll dann nur Ergebnis "Brunnengasse im Ortsteil Buch am Ahorn" angezeigt werden.

Wenn möglich das auch mit mehr als 2 Wörtern.

Geht sowas den? Vor allem ist es möglich eine Tabelle mit ca 2000 Zeilen so schnell zu durchsuchen?

Vielen Dank für Hilfe

Vielen Dank und Viele Grüße
Sebastian

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub TextBox1_Change() Dim arrSuche, i&, j& arrSuche = Split(TextBox1, ",") ListBox1.Clear With Tabelle1 For i = 0 To UBound(arrSuche) For j = 2 To 100 If arrSuche(i) > "" And InStr(1, .Cells(j, 2), arrSuche(i)) > 0 Then ListBox1.AddItem .Cells(j, 2) ListBox1.List(ListBox1.ListCount - 1, 1) = .Cells(j, 3) End If Next j Next i End With End Sub

'Unter Anbindung der Bibliotheken (VB-Editor, Extras, Verweise): '_ Microsoft VBScript Regular Expressions 5.5 Public Function Mehrteilig_finden(R As Range, ParamArray Teile()) Dim Re As New RegExp Dim E Dim Erg Re.Pattern = Join(Teile, "[\s\S]*") Re.IgnoreCase = True Erg = Array() For Each E In R.Value 'Übernahme der Inhalt in einem Array If Re.Test(E) Then ReDim Preserve Erg(UBound(Erg) + 1) Erg(UBound(Erg)) = E End If Next Mehrteilig_finden = Erg End Function Sub Test() Dim E For Each E In Mehrteilig_finden(Worksheets("Tabelle1").Range("A1:A2"), "brun", "aho") 'in A1:A2 sin deine Test-Adresse abgelegt Debug.Print E Next End Sub

Hi,

lösch innerhalb von TextBox1_Change erst mal alles, auch deinen alten Code.

Schreib dann ins Intialize-Ereignis diesen Code



Private Sub UserForm_Initialize()



    Dim Typ_tabelle As Worksheet

    Dim lloRow As Long

    

    Set Typ_tabelle = Sheets("Tabelle1")

    

        With ListBox1

            .ColumnWidths = "0 cm; 15 cm;2 cm;0 cm;0 cm"

            .ColumnCount = 5

            .Clear

        End With



        With Typ_tabelle

            For lloRow = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row

                ListBox1.AddItem

                ListBox1.List(ListBox1.ListCount - 1, 0) = lloRow

                ListBox1.List(ListBox1.ListCount - 1, 1) = .Cells(lloRow, 2)

                ListBox1.List(ListBox1.ListCount - 1, 2) = .Cells(lloRow, 3)

            Next

        End With



End Sub

und schreib nun ins Private Sub TextBox1_Change() diesen Code



    Dim arrSuche, liIdx As Integer, lloRow As Long, lboOK As Boolean

    arrSuche = Split(TextBox1, " ")

    ListBox1.Clear

    With Tabelle1

        For lloRow = 2 To 100

            For liIdx = 0 To UBound(arrSuche)

                If InStr(1, LCase(.Cells(lloRow, 2)), LCase(arrSuche(liIdx))) > 0 Then

                        lboOK = True

                    Else

                        lboOK = False

                        Exit For

                End If

            Next

            If lboOK = True Then

                ListBox1.AddItem lloRow

                ListBox1.List(ListBox1.ListCount - 1, 1) = .Cells(lloRow, 2)

                ListBox1.List(ListBox1.ListCount - 1, 2) = .Cells(lloRow, 3)

            End If

        Next

    End With

Bei mir läufts - bei dir auch?

Ciao
Thorsten

Private Sub TextBox1_Change() Dim arrSuche, arrErg As Variant, iSpalten&, iSp&, i&, j&, k& arrSuche = Split(TextBox1, " ") iSpalten = 2 With Tabelle1 ReDim arrErg(1 To .Cells(Rows.Count, 2).End(xlUp).Row, 1 To 2) For i = 0 To UBound(arrSuche) For j = 2 To .Cells(Rows.Count, 2).End(xlUp).Row If arrSuche(i) > "" And InStr(1, .Cells(j, 2), arrSuche(i)) > 0 Then k = k + 1 For iSp = 1 To iSpalten arrErg(k, iSp) = .Cells(j, iSp + 1) Next iSp End If Next j Next i End With If k = 0 Then ListBox1.Clear Exit Sub End If arrErg = Application.WorksheetFunction.Transpose(arrErg) ReDim Preserve arrErg(1 To iSpalten, 1 To k) arrErg = Application.Transpose(arrErg) With ListBox1 .ColumnCount = iSpalten .List = arrErg End With End Sub

Beliebteste Forumthreads (12 Monate)

Textbox (Suche) mit mehreren Wörtern und ausgabe in Listbox

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Textbox (Suche) mit mehreren Wörtern und ausgabe in Listbox

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

302 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread