Sub Filtern()
Set r = Range("A1:E6")
crit1 = "Gruppe2"
crit2 = "Name7"
Application.ScreenUpdating = False
If Not FilterIsActive(r) Then
r.AutoFilter
fseton = True
End If
If r.Parent.AutoFilter.FilterMode = True Then
r.AutoFilter
r.AutoFilter
End If
r.AutoFilter Field:=1, Criteria1:=crit1
r.AutoFilter Field:=2, Criteria1:=crit2
imax = Application.Count(r.Columns(3).SpecialCells(xlCellTypeVisible))
For i = 1 To imax
r.AutoFilter Field:=3
r.AutoFilter Field:=4
r.AutoFilter Field:=3, Criteria1:=CStr(CDate(Application.Large(r.Columns(3).SpecialCells(xlCellTypeVisible), i)))
kmax = Application.Count(r.Columns(4).SpecialCells(xlCellTypeVisible))
For k = 1 To kmax
r.AutoFilter Field:=4
r.AutoFilter Field:=4, Criteria1:=CStr(CDate(Application.Large(r.Columns(4).SpecialCells(xlCellTypeVisible), k)))
If r.Columns(5).SpecialCells(xlCellTypeVisible).Areas.Count = 1 Then
Wert = r.Columns(5).SpecialCells(xlCellTypeVisible).Areas(1).Cells(2).Value
Else
Wert = r.Columns(5).SpecialCells(xlCellTypeVisible).Areas(2).Cells(1).Value
End If
If Wert <> "" And Wert <> 0 And Wert <> "000.000.000" Then gefunden = True
If gefunden = True Then Exit For
Next k
If gefunden = True Then Exit For
Next i
Application.ScreenUpdating = True
If gefunden = False Then MsgBox "Für die Kriterien " & crit1 & " und " & crit2 & " gibt es keinen gültigen Wert!", vbExclamation Else MsgBox "Wert: " & Wert, vbInformation
If fseton Then
r.AutoFilter
End If
End Sub
Function FilterIsActive(ByVal r As Range) As Boolean
On Error Resume Next
FilterIsActive = r.Parent.AutoFilter.Filters.Count > 0
End Function