Listboxeintrag über Textbox filtern

Werner · 2013-11-22T03:22:23+00:00

Hallo Experten, ich lese mit folgendem Code Daten aus einer Tabelle in eine mehrspaltige Listbox ein: Private Sub UserForm_Activate() Application.ScreenUpdating = False Nachname = "" Vorname = "" GDatum = "" Dim X As Long Dim I As Integer Application.ScreenUpdating = False Worksheets("Jahrestabelle").Activate Me.Personalien.Clear X = Range("D" & Rows.Count).End(xlUp).Row For I = 5 To X Me.Personalien.AddItem Personalien.List(Personalien.ListCount - 1, 0) = Cells(I, 4) Personalien.List(Personalien.ListCount - 1, 1) = Cells(I, 5) Personalien.List(Personalien.ListCount - 1, 2) = Cells(I, 6) Personalien.List(Personalien.ListCount - 1, 3) = Cells(I, 8) Personalien.List(Personalien.ListCount - 1, 4) = Cells(I, 9) Personalien.List(Personalien.ListCount - 1, 5) = Cells(I, 10) Personalien.List(Personalien.ListCount - 1, 6) = Cells(I, 11) Personalien.List(Personalien.ListCount - 1, 7) = Cells(I, 12) Personalien.List(Personalien.ListCount - 1, 8) = Cells(I, 13) Personalien.List(Personalien.ListCount - 1, 9) = I Next I Application.ScreenUpdating = True End Sub Nun möchte ich die Spalten 0, 1 und 2 der Listbox durch Eingaben in drei Textboxen filtern. Kriege es leider nicht hin. Könnt ihr mir bitte helfen. Grüße Werner

Hallo,
kannst mal so versuchen.
In der Sub FilterDaten kommt noch diese Zeile hinzu.
ReDim Preserve ArFilter(1 To UBound(ArFilter), 1 To nCount)

Private Sub Ändern_Click()
Dim ZielZeile As Long
'kein Datensatz ausgewählt 
If Personalien.ListIndex = -1 Then Exit Sub
'Zeile aus Listbox auslesen 
If IsNumeric(Personalien.List(, 9)) Then
    ZielZeile = Personalien.List(, 9)
Else 'Eintrag hat keine Zeilennummer (sollte aber nicht vorkommen!) 
    Exit Sub
End If

On Error GoTo ErrFehler:
Application.ScreenUpdating = False
With Worksheets("Jahrestabelle")
    .Protect Password:="*****", UserInterfaceonly:=True
    .Cells(ZielZeile, 4) = Familienname.Text
    .Cells(ZielZeile, 5) = Vorname.Text
    .Cells(ZielZeile, 6) = CDate(GebDatum)
    .Cells(ZielZeile, 8) = CDate(Datum)
    .Cells(ZielZeile, 9) = Störung.Text
    .Cells(ZielZeile, 10) = Straftat.Text
    .Cells(ZielZeile, 11) = Verweis.Text
    .Cells(ZielZeile, 12) = OE.Text
    .Cells(ZielZeile, 13) = Eigene.Text
End With

ErrFehler:
Unload Me
Worksheets("Dateneingabe").Activate
Application.ScreenUpdating = True

If Err.Number <> 0 Then
    MsgBox Err.Description, _
           vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
           "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub

Private Sub TextBox1_Change()
Call FilterDaten(TextBox1, TextBox2, TextBox3)
End Sub

Private Sub TextBox2_Change()
Call FilterDaten(TextBox1, TextBox2, TextBox3)
End Sub

Private Sub TextBox3_Change()
Call FilterDaten(TextBox1, TextBox2, TextBox3)
End Sub

Private Sub UserForm_Activate()
Call FilterDaten
End Sub

Private Sub FilterDaten(Optional sFilter1$, Optional sFilter2$, Optional sFilter3$)
Dim ArData, ArFilter()
Dim X As Long, n&, nn&, nCount&

Me.Personalien.Clear
With Worksheets("Jahrestabelle")
    X = Range("D" & Rows.Count).End(xlUp).Row
    If X < 5 Then Exit Sub
    ArData = .Range("D5", .Cells(X, 13))
End With

Redim Preserve ArFilter(1 To Ubound(ArData, 2) + 1, 1 To Ubound(ArData) + 1)

If sFilter1 & sFilter2 & sFilter3 = "" Then
    For n = 1 To Ubound(ArData)
        nCount = nCount + 1
        For nn = 1 To Ubound(ArData, 2) - 1
            ArFilter(nn, nCount) = ArData(n, nn)
        Next nn
        ArFilter(nn, nCount) = n + 4
    Next n
Else
    sFilter1 = sFilter1 & "*"
    sFilter2 = sFilter2 & "*"
    sFilter3 = sFilter3 & "*"
    
    For n = 1 To Ubound(ArData)
        If ArData(n, 1) Like sFilter1 Then
            If ArData(n, 2) Like sFilter2 Then
                If ArData(n, 3) Like sFilter3 Then
                    nCount = nCount + 1
                    For nn = 1 To Ubound(ArData, 2) - 1
                        ArFilter(nn, nCount) = ArData(n, nn)
                    Next nn
                    ArFilter(nn, nCount) = n + 4
                End If
            End If
        End If
    Next n
End If

If nCount > 0 Then
    Redim Preserve ArFilter(1 To Ubound(ArFilter), 1 To nCount)
    Personalien.ColumnCount = Ubound(ArFilter)
    Personalien.List = Application.Transpose(ArFilter)
Else
    MsgBox "keine Daten gefunden"
End If
End Sub

Gruß Tino

Hallo,
kannst mal so testen.
In der Zeile varNotSpalte = Array(7) kannst Du die Spalten anpassen die ausgelassen werden sollen.
Soll zBsp. noch die Spalte 9 ausgelassen werden dann varNotSpalte = Array(7, 9)
Die Spalten müssen aber innerhalb vom Range liegen, also hier Spalte 4 bis 13.
Der Offset fürs Array wird im Code berechnen,
weil im Array ArData die Spalte 1 in der Tabelle die Spalte 4 ist!

Private Sub FilterDaten(Optional sFilter1$, Optional sFilter2$, Optional sFilter3$)
Dim ArData, ArFilter()
Dim X As Long, n&, nn&, nCount&, nRow&
Dim varNotSpalte
'Spalten auslassen entsprechend auffüllen Array(7,10) 
'Spalte muss sich innerhalb .Range("D5", .Cells(X, 13)) also hier Spalte 4 bis 13 befinden!!!! 
varNotSpalte = Array(7, 9)

Me.Personalien.Clear
With Worksheets("Jahrestabelle")
    X = Range("D" & Rows.Count).End(xlUp).Row
    If X < 5 Then Exit Sub
    With .Range("D5", .Cells(X, 13))
        ArData = .Value
        nRow = .Columns(1).Column - 1
    End With
End With
For X = Lbound(varNotSpalte) To Ubound(varNotSpalte)
    varNotSpalte(X) = varNotSpalte(X) - nRow
Next X
Redim Preserve ArFilter(1 To Ubound(ArData, 2) + 1, 1 To Ubound(ArData) + 1)

If sFilter1 & sFilter2 & sFilter3 = "" Then
    For n = 1 To Ubound(ArData)
        nCount = nCount + 1
        nRow = 0
        For nn = 1 To Ubound(ArData, 2) - 1
            If Not IsNumeric(Application.Match(nn, varNotSpalte, 0)) Then
                nRow = nRow + 1
                ArFilter(nRow, nCount) = ArData(n, nn)
            End If
        Next nn
        nRow = nRow + 1
        ArFilter(nRow, nCount) = n + 4
    Next n
Else
    sFilter1 = sFilter1 & "*"
    sFilter2 = sFilter2 & "*"
    sFilter3 = sFilter3 & "*"
    
    For n = 1 To Ubound(ArData)
        If ArData(n, 1) Like sFilter1 Then
            If ArData(n, 2) Like sFilter2 Then
                If ArData(n, 3) Like sFilter3 Then
                    nCount = nCount + 1
                    nRow = 0
                    For nn = 1 To Ubound(ArData, 2) - 1
                        If Not IsNumeric(Application.Match(nn, varNotSpalte, 0)) Then
                            nRow = nRow + 1
                            ArFilter(nRow, nCount) = ArData(n, nn)
                        End If
                    Next nn
                    nRow = nRow + 1
                    ArFilter(nRow, nCount) = n + 4
                End If
            End If
        End If
    Next n
End If

If nCount > 0 Then
    Redim Preserve ArFilter(1 To Ubound(ArFilter), 1 To nCount)
    ArFilter = Application.Transpose(ArFilter)
    Redim Preserve ArFilter(1 To Ubound(ArFilter), 1 To Ubound(ArFilter, 2) - (Ubound(varNotSpalte) + 1))
    Personalien.ColumnCount = Ubound(ArFilter, 2)
    Personalien.List = ArFilter
Else
    MsgBox "keine Daten gefunden"
End If
End Sub

Gruß Tino

Listboxeintrag über Textbox filtern

Forumthread: Listboxeintrag über Textbox filtern

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Listboxeintrag über Textbox filtern

Forumthread: Listboxeintrag über Textbox filtern

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread