Mehrspaltige Listbox filtern

Hallo zusammen,
leider habe ich auf meinen letzten Beitrag noch keine Antwort bekommen. Daher versuche ich es erneut.
Wie kann ich eine Listbox anhand einer Eingabe, z.B. in eine Textbox filtern?
So sieht meine zu filternde Liste aus:


Straße	           Ort	         Ortsteil    PLZ	Zusatz	    Tour  Altern. Komm.
Aachener Straße	   Saarbrücken   Burbach     66115	Hochstraße  S07
Abstäberhof	   Kirkel	 Neuhäusel   66459	 	    S13
Abteistraße	   Tholey	 Tholey	     66636	 	    B02
Abteistraße	   Merzig	 Besseringe  66663	 	    B16
Abteistraße	   Wadgassen     Wadgassen   66787	 	    B23
Abt-Fulrad-Str	   Kleinblittersdorf	     66271	 	    S11	  S13

Sie umfasst ca. 15.000 Zeilen.
Ich habe bisher für jede Spalte eine Textbox eingefügt. Also für die Suche einer Straße, füe die Suche eines Ortes, usw.
Die Listbox erzeuge ich über folgenden Code:


Private Sub Userform_initialize()
Dim loletzteX As Long
loletzteX = Sheets("Touren").Cells(Rows.Count,1).End(xlUp).Row
With ListBox1
.ColumnCount = 8
.ColumnWidths = "5cm;5cm;4cm;2cm;3cm;1,5cm;2cm;3cm;"
.ColumnHeads = True
ListBox1.RowSource = "Touren!B2:I" & loletzteX
End With
ListBox1.ListIndex = ListBox1.ListCount - 1
End Sub

Ich hoffe es kann mir geholfen werden. Danke bereits im Voraus.

Hallo Linus,
ich habe jetzt eine Volltextsuche programmiert. Die Groß-/Kleinschreibung wird berücksichtigt
Der Suchbegriff ist in TextBox1 einzutragen. Bei 15 Zeilen kann die Suche evtl. langsam sein, musst du mal austesten:

Private Sub TextBox1_Change()
Dim arrData As Variant, arrData2 As Variant
Dim iLastRow As Integer
With Worksheets("Touren")
iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
arrData = .Range(.Cells(2, 2), .Cells(iLastRow, 9)).Value
End With
If Not Trim(TextBox1) = Empty Then
arrData2 = filter2dArray(arrData, "*" & TextBox1.Text & "*")
End If
If VarType(arrData2) = Empty Then
ListBox1.Clear
Else
ListBox1.List() = arrData2
End If
End Sub
Function filter2dArray(sourceArr As Variant, matchStr As String) As Variant
Dim matchArrIndex As Variant, splitArr As Variant
Dim i As Integer, outerindex As Integer, innerIndex As Integer, tempArrayIndex As Integer,  _
CurrIndex As Integer, stringLength As Integer, matchType As Integer
Dim increaseIndex As Boolean
Dim actualStr As String
splitArr = Split(matchStr, "*")
On Error GoTo errorHandler
If UBound(splitArr) = 0 Then
matchType = 0 'Exact Match
actualStr = matchStr
ElseIf UBound(splitArr) = 1 And splitArr(1) = "" Then
matchType = 1 'Starts With
actualStr = splitArr(0)
ElseIf UBound(splitArr) = 1 And splitArr(0) = "" Then
matchType = 2 'ends With
actualStr = splitArr(1)
ElseIf UBound(splitArr) = 2 And splitArr(0) = "" And splitArr(2) = "" Then
matchType = 3 'contains
actualStr = splitArr(1)
Else
MsgBox "Incorrect match provided"
Exit Function
End If
'start index
i = LBound(sourceArr, 1)
'resize array for matched values
ReDim matchArrIndex(LBound(sourceArr, 1) To UBound(sourceArr, 1)) As Variant
'outer loop
For outerindex = LBound(sourceArr, 1) To UBound(sourceArr, 1)
'inner loop
For innerIndex = LBound(sourceArr, 2) To UBound(sourceArr, 2)
'if string matches with array elements
If (matchType = 0 And sourceArr(outerindex, innerIndex) = actualStr) Or _
(matchType = 1 And Left(sourceArr(outerindex, innerIndex), Len(actualStr)) =  _
actualStr) Or _
(matchType = 2 And Right(sourceArr(outerindex, innerIndex), Len(actualStr)) =  _
actualStr) Or _
(matchType = 3 And InStr(sourceArr(outerindex, innerIndex), actualStr)  0)  _
Then
increaseIndex = True
matchArrIndex(i) = outerindex
End If
Next
If increaseIndex Then
tempArrayIndex = tempArrayIndex + 1
increaseIndex = False
i = i + 1
End If
Next
'if no matches found, exit the function
If tempArrayIndex = 0 Then
Exit Function
End If
If LBound(sourceArr, 1) = 0 Then
tempArrayIndex = tempArrayIndex - 1
End If
'resize temp array
ReDim tempArray(LBound(sourceArr, 1) To tempArrayIndex, LBound(sourceArr, 2) To UBound( _
sourceArr, 2)) As Variant
CurrIndex = LBound(sourceArr, 1)
Dim j As Integer
j = LBound(matchArrIndex)
'store values in temp array
For i = CurrIndex To UBound(tempArray)
For innerIndex = LBound(sourceArr, 2) To UBound(sourceArr, 2)
tempArray(i, innerIndex) = sourceArr(matchArrIndex(j), innerIndex)
Next
j = j + 1
Next
filter2dArray = tempArray
Exit Function
errorHandler:
MsgBox "Error :" & Err.Description
End Function

Forumthread: Mehrspaltige Listbox filtern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Mehrspaltige Listbox in Excel filtern

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)