Ich habe nochmals etwas "rumgespielt"...
Boris
Hi K.Rola,
...um den Code (so gut wie möglich) allgemeingültig zu gestalten.
Zudem hab ich noch 2 kleine Functions eingebaut.
Speziell zur F unction "Bedingung" ist mir nix Besseres eingefallen...
Wäre toll, wenn du dein fachfräuliches Auge da auch mal rübergleiten lassen kannst.
Option Explicit
Option Base 1
Sub aktive_Filter()
Dim i 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
'Wenn irgendein Filter aktiv ist, dann
If .FilterMode Then
'In welcher Spalte beginnt der Autofilter (minus 1)
iCol = .AutoFilter.Range.Column - 1
'In welcher Zeile beginnt der Autofilter
'Dabei wird unterstellt, dass in dieser Zeile die Überschriften stehen
lRow = .AutoFilter.Range.Row
'Schleife über alle Filter
For i = 1 To .AutoFilter.Filters.Count
'Wenn Filter i aktiv ist, dann
If .AutoFilter.Filters(i).On Then
'Zähler um 1 erhöhen
iCount = iCount + 1
ReDim Preserve myArray(7, 1 To iCount)
'Spaltenbuchstaben ermitteln
myArray(1, iCount) = Application.Substitute(Cells(1, i + iCol).Address(0, 0), 1, "")
'Überschrift ermitteln und gleichzeitig bereinigen um
'Zeilenumbrüche und Trenn-/Bindestriche
myArray(2, iCount) = Trim(Application.Substitute(Application.Substitute(.Cells(lRow, i + iCol), _
Chr(10), " "), "-", ""))
'Bedingung 1 ermitteln und in Text umwandeln
strTemp = .AutoFilter.Filters(i).Criteria1
myArray(3, iCount) = Bedingung(strTemp)
'Eigentliches Kriterium um <, >, = und * bereinigen
myArray(4, iCount) = Bereinigen(strTemp)
strTemp = ""
On Error Resume Next
'Operator ermitteln
myArray(5, iCount) = IIf(.AutoFilter.Filters(i).Operator = xlAnd, "und", "oder")
'Bedingung 2 ermitteln und in Text umwandeln
strTemp = .AutoFilter.Filters(i).Criteria2
myArray(6, iCount) = Bedingung(strTemp)
'Eigentliches Kriterium um <, >, = und * bereinigen
myArray(7, iCount) = Bereinigen(strTemp)
strTemp = ""
'Überflüssigen Operator entfernen
'sofern keine und/oder-Bedingung existiert
If myArray(6, iCount) = "" Then myArray(5, iCount) = ""
On Error GoTo 0
End If
Next i
Else
MsgBox "Der Autofiltermodus ist im aktiven Blatt nicht aktiv...", , "Kleiner Hinweis..."
Exit Sub
End If
End With
'Ausgabetabelle vorbereiten, formatieren und Daten aus myArray hineinschreiben
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) = WorksheetFunction.Transpose(myArray)
.Columns("A:G").AutoFit
End With
End Sub
Function Bedingung(str As String) As String
If InStr(1, str, "=") And InStr(1, str, "*") And InStr(3, str, "*") Then Bedingung = "enthält": Exit Function
If InStr(1, str, "=") And InStr(3, str, "*") Then Bedingung = "beginnt mit": Exit Function
If InStr(1, str, "<>") And InStr(1, str, "*") And InStr(4, str, "*") Then Bedingung = "enthält nicht": Exit Function
If InStr(1, str, "=") And InStr(3, str, "*") Then Bedingung = "beginnt nicht mit": Exit Function
If InStr(1, str, "=") And InStr(1, str, "*") And InStr(3, str, "*") Then Bedingung = "enthält": Exit Function
If InStr(1, str, "=") And InStr(1, str, "*") Then Bedingung = "endet mit": Exit Function
If InStr(1, str, "<>") And InStr(1, str, "*") Then Bedingung = "endet nicht mit": Exit Function
If InStr(1, str, "<=") Then Bedingung = "kleiner oder gleich": Exit Function
If InStr(1, str, ">=") Then Bedingung = "größer oder gleich": Exit Function
If InStr(1, str, "<>") Then Bedingung = "entspricht nicht": Exit Function
If InStr(1, str, "<") Then Bedingung = "kleiner als": Exit Function
If InStr(1, str, ">") Then Bedingung = "größer als": Exit Function
If InStr(1, str, "=") Then Bedingung = "entspricht": Exit Function
str = ""
End Function
Function Bereinigen(str As String) As String
With WorksheetFunction
Bereinigen = .Substitute(.Substitute(.Substitute(.Substitute(str, ">", ""), "<", ""), "=", ""), "*", "")
End With
End Function
Grüße Boris