Excel - Dynamischer Filter

[Lars1904]

Hallo zusammen,

ich bin absoluter Anfänger auf dem Bereich VBA-Programmierung, benötigte aber kurz Hilfe von jemanden.

Ich würde gerne einen dynamischen Filter mit mehreren Kriterien benutzen.

Im Internet habe ich folgenden Code für ein Kriterium gefunden, der gut funktioniert. Aber wie gesagt lediglich ein Kriterium abbildet.

-> Wie müsste ich den Code abändern, wenn ich mehrere Kriterien beispielsweise in Zelle B1 durch Kommatrennung heranziehen will?
--> Bezogen auf die Excel Datei: Ich würde in B1 gerne nach Bernd, Hans und Willi filtern. 

Vielen Dank im Voraus!



Option Explicit                    ' Variablendeklaration erforderlich

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'**************************************************
'* 09.02.08,11.03.08,31.03.08                    *
'* erstellt von Karin (Beverly), http://Excel-Inn.de*
'* Beverly_Forums@web.de                          *
'**************************************************
    Dim raBereich As Range
    Dim raZelle As Range            ' Variable für die Zelle als Range
'  Wirkung des Codes auf Zeile 1 der Tabelle im Filterbereich zulassen
    Set raBereich = Intersect(Target, Range(Cells(1, ActiveSheet.AutoFilter.Range(1).Column), _
        Cells(1, ActiveSheet.AutoFilter.Range(1).Column + ActiveSheet.AutoFilter.Filters.Count - 1)))
'  Eingabe erfolgte im festgelegten Bereich
    If Not raBereich Is Nothing Then
'      Bildschirmaktualisierung aus
        Application.ScreenUpdating = False
'      Reaktion auf Eingabe abschalten
        Application.EnableEvents = False
'      Schleife über alle Zellen der Zeile 1 der Tabelle
        For Each raZelle In raBereich
'          Bezieht sich auf den Filterbereich
            With ActiveSheet.AutoFilter.Range
'              Eingabe wurde gelöscht
                If raZelle = "" Then
'                  Autofilter für das betreffende Fald zurücksetzen
                    .AutoFilter Field:=raZelle.Column + 1 - ActiveSheet.AutoFilter.Range(1).Column
'                  in die betreffende Zelle eintragen
                    raZelle = "Suchbegriff eingeben"
                Else
'                  Suchkriterium ist eine Zahl
                    If IsNumeric(raZelle) Then
'                      Autofilter für das betreffende Feld setzen, Filterkriterium "entspricht"
                        .AutoFilter Field:=raZelle.Column + 1 - ActiveSheet.AutoFilter.Range(1).Column, _
                            Criteria1:="=" & raZelle
'                  Suchkriterium ist ein Datum
                    ElseIf IsDate(raZelle) Then
'                      Autofilter für das betreffende Feld setzen
'                      es werden 2 Kriterien verwendet, weil mit Kriterium "=" das Datum nicht gefiltert wird
                        .AutoFilter Field:=raZelle.Column + 1 - ActiveSheet.AutoFilter.Range(1).Column, _
                            Criteria1:=">=" & raZelle.Value2, Criteria2:="<=" & raZelle.Value2
                    Else
'                      Autofilter für das betreffende Feld setzen, Filterkriterium "Enthält"
                        .AutoFilter Field:=raZelle.Column + 1 - ActiveSheet.AutoFilter.Range(1).Column, _
                            Criteria1:="=*" & raZelle & "*"
                    End If
                End If
            End With
        Next raZelle
'      Reaktion auf Eingabe einschalten
        Application.EnableEvents = True
'      Bildschirmaktualisierung ein
        Application.ScreenUpdating = True
    End If
End Sub

[Kuwer]

Hallo,

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

  Dim rngC As Range

  Dim varC As Variant

  With Target.Cells(1)

    Set rngC = Application.Intersect(.Cells, Me.AutoFilter.Range.EntireColumn.Rows(1))

    If Not rngC Is Nothing Then

      varC = Split(.Value, ",")

      If UBound(varC) = -1 Then

        Me.AutoFilter.Range.AutoFilter Field:=rngC.Column - Me.AutoFilter.Range.Column + 1

      Else

        Me.AutoFilter.Range.AutoFilter Field:=rngC.Column - Me.AutoFilter.Range.Column + 1, Criteria1:=varC, Operator:=xlFilterValues

      End If

    End If

  End With

End Sub

Gruß Uwe

[Lars1904]

Vielen Dank! Das ist es, du hast mir sehr geholfen!