AW: Ansatz - hier auch mal der gesamte Hintergrund
Boris
Hi Martin,
schau Dir mal die Hilfe zu FILTERS an. Wenn ich Dich recht verstehe, möchtest Du das Calculate-Ereignis ausnutzen, wenn neu gefiltert wird. Dann ändert sich aber die Filters-Auflistung, und Du müßtest "nur" die alte mit der neuen Liste vergleichen.
Die Filters-Auflistung muss sich nicht unbedingt ändern.
Wenn ich Spalte C nach Top10 gefiltert habe, dann ist der Filter aktiv. Filtere ich jetzt die gleiche Spalte nach nem anderen Kriterium, dann ist der Filter aber immer noch aktiv - es liegt also keine Änderung in der Filter-Auflistung vor und das Calculate-Ereignis würde nicht angestoßen (was ich aber gerne möchte).
Hintergrund: Es geht mir darum, die Filterkriterien eines mittels Autofilter gefilterten Blattes in einem separaten Blatt auszulesen.
Dazu habe ich inzwischen folgenden Code gebastelt, der mit Hilfe von K.Rola, Nancy und "Well Ness" bereits etwas verfeinert wurde.
Der Code funktioniert soweit fehlerfrei - nur möchte ich ihn nicht manuell starten, sondern eben automatisch in dem Moment, in dem irgendwo gefiltert wird.
Es gibt derzeit nur noch Auswertungsfehler (bei der UDF "Bedingung"), wenn in den gefilterten Zellen die Zeichen ">,
Ist sicherlich nur das i-Tüpfelchen, aber ich möchte es eben gerne versuchen.
Hier der gesamte Code (einfach komplett in ein allgemeines Modul):
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
Dim Blatt As String
Blatt = "AF-Kriterien"
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")
'Behelf, falls z.B. nach Top10 gefiltert wurde (=Operator 3 und größer)
'Da dabei kein 2. Kriterium existiert, käme es zu einem Fehler
If .AutoFilter.Filters(i).Operator < 3 Then 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..."
If BlattExistent(Blatt) Then Worksheets(Blatt).Cells.ClearContents
Exit Sub
End If
End With
If BlattExistent(Blatt) = False Then
Application.ScreenUpdating = False
Worksheets.Add after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = Blatt
Ash.Activate
Application.ScreenUpdating = True
End If
With Worksheets(Blatt)
.Cells.ClearContents
.[a1:g1] = Array("Spalte", "Überschrift", "Bedingung 1", "Kriterium 1", "Operator", "Bedingung 2", "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
Function BlattExistent(Blattname As String) As Boolean
Dim Sh As Object
For Each Sh In ThisWorkbook.Sheets
If Sh.Name = Blattname Then BlattExistent = True
Next Sh
End Function
Grüße Boris