Autofilter - Kriterien auslesen
Boris
Hi Maik,
ich hab mir seinerzeit mal - auch mit Hilfe des Forums - einen Code gebastelt, der die Filterkriterien ausliest.
Voraussetzung:
Lege ein separates Tabellenblatt mit dem Namen "Daten" an.
Pack den gesamten Code in ein allgemeines Modul und starte ihn via Button (oder sonst wie).
Dann kannst du auf das Blatt "Daten" auch mit deinem Userform zurückgreifen.
Er ist noch nicht ganz ausgreift - z.B. Top10-Filterung geht noch nicht - aber prinzipell funktioniert er sonst.
Option Explicit
Option Base 1
Sub aktive_Filter()
Dim i As Integer
Dim j As Integer
Dim iCount As Integer
Dim Ash As Worksheet
Dim iCol As Integer
Dim myArray() As Variant
Dim strTemp As String
Dim lRow As Long
Set Ash = ActiveSheet
With Ash
If .FilterMode Then
iCol = .AutoFilter.Range.Column - 1
lRow = .AutoFilter.Range.Row
For i = 1 To .AutoFilter.Filters.Count
If .AutoFilter.Filters(i).On Then iCount = iCount + 1
Next i
ReDim myArray(iCount, 7)
For i = 1 To .AutoFilter.Filters.Count
If .AutoFilter.Filters(i).On Then
j = j + 1
myArray(j, 1) = Application.Substitute(Cells(1, i + iCol).Address(0, 0), 1, "")
myArray(j, 2) = Trim(Application.Substitute(Application.Substitute(.Cells(lRow, i + iCol), _
Chr(10), " "), "-", ""))
strTemp = .AutoFilter.Filters(i).Criteria1
myArray(j, 3) = Bedingung(strTemp)
myArray(j, 4) = Bereinigen(strTemp)
strTemp = ""
If .AutoFilter.Filters(i).Operator <> 0 Then
myArray(j, 5) = IIf(.AutoFilter.Filters(i).Operator = xlAnd, "und", "oder")
strTemp = .AutoFilter.Filters(i).Criteria2
myArray(j, 6) = Bedingung(strTemp)
myArray(j, 7) = Bereinigen(strTemp)
strTemp = ""
End If
End If
Next i
Else
MsgBox "Der Autofiltermodus ist im aktiven Blatt nicht aktiv...", , "Kleiner Hinweis..."
Worksheets("Daten").Cells.ClearContents
Exit Sub
End If
End With
With Worksheets("Daten")
.Cells.ClearContents
.[a1] = "Spalte": .[b1] = "Überschrift": .[c1] = "Bedingung 1": .[d1] = "Kriterium 1"
.[e1] = "Operator": .[f1] = "Bedingung 2": .[g1] = "Kriterium 2"
.[a1:g1].Font.Bold = True
If iCount Then .Range("A2:G" & iCount + 1) = myArray
.Columns("A:G").AutoFit
End With
End Sub
Function Bedingung(str As String) As String
With WorksheetFunction
If Len(str) - Len(.Substitute(.Substitute(str, "=", ""), "*", "")) = 3 Then Bedingung = "enthält": Exit Function
If Len(str) - Len(.Substitute(.Substitute(str, "<>", ""), "*", "")) = 4 Then Bedingung = "enthält nicht": Exit Function
If InStr(1, str, "<>*") > 0 Then Bedingung = "endet nicht mit": Exit Function
If Len(str) - Len(.Substitute(.Substitute(str, "<>", ""), "*", "")) = 3 Then Bedingung = "beginnt nicht mit": Exit Function
If InStr(1, str, "=*") > 0 Then Bedingung = "endet mit": Exit Function
If Len(str) - Len(.Substitute(.Substitute(str, "=", ""), "*", "")) = 2 Then Bedingung = "beginnt mit": Exit Function
If InStr(1, str, "<=") > 0 Then Bedingung = "kleiner oder gleich": Exit Function
If InStr(str, ">=") > 0 Then Bedingung = "größer oder gleich": Exit Function
If InStr(1, str, "<>") > 0 Then Bedingung = "entspricht nicht": Exit Function
If InStr(1, str, "<") > 0 Then Bedingung = "kleiner als": Exit Function
If InStr(1, str, ">") > 0 Then Bedingung = "größer als": Exit Function
If InStr(1, str, "=") > 0 Then Bedingung = "entspricht": Exit Function
Bedingung = ""
End With
End Function
Function Bereinigen(str As String) As String
With WorksheetFunction
Bereinigen = .Substitute(.Substitute(.Substitute(.Substitute(str, ">", ""), "<", ""), "=", ""), "*", "")
End With
End Function
Grüße Boris