Filterkriterium nicht erfüllt
09.07.2021 23:53:26
Peter
hat einer eine Idee, warum mir mein Code alle Datensätze kopiert, wenn eines der beiden geforderten FIlterkriterium nicht erfüllt ist? Solange er beide Kriterien in der Liste findet, klappt es. Leider nicht, wenn eines nicht erfüllt ist. Es müssen beide Filterkriterien erfüllt sein, dann sollte der Datensatz in seinen Bereich kopiert werden, ansonsten eben nicht.
Hier der Code:
Option Explicit
Private Sub Worksheet_activate()
Dim i As Long, ws As Worksheet, strDatum As String, daDatum As Date
Dim Suchkriterium As String
Dim RangeZiel As String
Application.ScreenUpdating = False
If ActiveSheet.Name Like "##.##.####" Then
strDatum = ActiveSheet.Name
daDatum = ActiveSheet.Name
With Worksheets("Einsatzprotokolle")
For i = 1 To 5
' .Range("C5").AutoFilter
If i = 1 Then Suchkriterium = "Frühdienst"
If i = 1 Then RangeZiel = "AE4:BB13"
If i = 2 Then Suchkriterium = "Spätdienst"
If i = 2 Then RangeZiel = "AE16:BB25"
If i = 3 Then Suchkriterium = "Nachtdienst"
If i = 3 Then RangeZiel = "AE28:BB37"
If i = 4 Then Suchkriterium = "Zusatzdienst 1"
If i = 4 Then RangeZiel = "AE40:BB49"
If i = 5 Then Suchkriterium = "Zusatzdienst 2"
If i = 5 Then RangeZiel = "AE52:BB61"
If WorksheetFunction.CountIf(.Columns("D"), daDatum) > 0 Then
.Range("C5").AutoFilter Field:=2, Criteria1:=strDatum
.Range("C5").AutoFilter Field:=5, Criteria1:=Suchkriterium
With ActiveSheet
.Range(RangeZiel).ClearContents
With Worksheets("Einsatzprotokolle").AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Columns("A:Z").Copy
End With
.Range(RangeZiel).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
.Range("C5").AutoFilter
End If
Next
.Range("C5").AutoFilter
End With
End If
Application.CutCopyMode = False
End Sub
Danke für Eure Hilfe