Hallo,
ich hatte das nicht ausgiebig getestet, da ich nur ein paar Datensaätze in der Testtabelle habe.
Ersetzte das vorhandene Makro durch den folgenden Code. Achte aber darauf, dass du die Function nicht löschst.
Hier der verbesserte Code:
Sub Alle_Filter_ubertragen()
Dim intSpalte As Integer
Dim strTabelle As String
Dim i As Integer
Dim f As Integer
Dim arrFilter(6, 4) As Variant
Dim bFilter As Boolean
Dim intFilterzeile As Integer
Dim myListObject As Object
'Bildschirmaktualisierung ausschalten:
'Application.ScreenUpdating = False
'prüfen, ob Daten im aktuellen Arbeitsblatt als Tabelle vorliegen
Set myListObject = testListObjects(ActiveSheet.Name)
'nun Filter entsprechend Ergebnis einlesen
If myListObject Is Nothing Then
'keine Tabelle
'Filter durchlaufen
For intSpalte = 1 To 6
With ActiveSheet.Autofilter.Filters(intSpalte)
If .On Then
arrFilter(intSpalte, 0) = Cells(ActiveSheet.Autofilter.Range(1).Row, intSpalte).Value 'Überschrift des Filters in Array schreiben
arrFilter(intSpalte, 1) = .Count 'Anzahl Filterkriterien in Array schreiben
arrFilter(intSpalte, 2) = .Operator 'Operator in Array schreiben
arrFilter(intSpalte, 3) = .Criteria1 'Kriterium 1 in Array schreiben
If .Count = 2 Then arrFilter(intSpalte, 4) = .Criteria2 'Kriterium 2 in Array schreiben
bFilter = True 'Marker, dass Filter gefunden wurde
End If
End With
Next intSpalte
Else
'Tabelle
'Filter durchlaufen
For intSpalte = 1 To 6
With ActiveSheet.ListObjects(1).Autofilter.Filters(intSpalte)
If .On Then
arrFilter(intSpalte, 0) = Cells(ActiveSheet.ListObjects(1).HeaderRowRange.Row, intSpalte).Value 'Überschrift des Filters in Array schreiben
arrFilter(intSpalte, 1) = .Count 'Anzahl Filterkriterien in Array schreiben
arrFilter(intSpalte, 2) = .Operator 'Operator in Array schreiben
arrFilter(intSpalte, 3) = .Criteria1 'Kriterium 1 in Array schreiben
If .Count = 2 Then arrFilter(intSpalte, 4) = .Criteria2 'Kriterium 2 in Array schreiben
bFilter = True 'Marker, dass Filter gefunden wurde
End If
End With
Next intSpalte
End If
'Falls kein Filter gefunden, dann Hinweis und Abbruch des Makros
If bFilter = False Then
MsgBox "Kein Filter gefunden! Abbruch", 64, "Hinweis"
Exit Sub
End If
'Name des aktiven Arbeitsblatts in Variable schreiben
strTabelle = ActiveSheet.Name
'alle Arbeitsblätter in Arbeitsmappe durchlaufen
For i = 1 To ThisWorkbook.Worksheets.Count
With ThisWorkbook.Worksheets(i)
'nur die anderen Arbeitsblätter durchlaufen
If .Name <> strTabelle Then
'prüfen, ob Daten im aktuellen Arbeitsblatt als Tabelle vorliegen
Set myListObject = testListObjects(.Name)
If myListObject Is Nothing Then
'keine Tabelle
'ggf. vorhandene Filter aufheben
If .FilterMode Then .ShowAllData
'Filter übertragen, dazu gespeicherte Filter durchlaufen
For f = 1 To 6
'Überschriften vergleichen
For intSpalte = 1 To 6
If arrFilter(f, 0) = .Cells(.Autofilter.Range(1).Row, intSpalte).Value Then
'Filter übertragen
Select Case arrFilter(f, 1)
Case Is = 1
.UsedRange.Autofilter Field:=f, Criteria1:=arrFilter(f, 3), Operator:=arrFilter(f, 2)
Case Is = 2
.UsedRange.Autofilter Field:=f, Criteria1:=arrFilter(f, 3), Operator:=arrFilter(f, 2), Criteria2:=arrFilter(f, 4)
Case Is > 2
.UsedRange.Autofilter Field:=f, Criteria1:=Array(arrFilter(f, 3)), Operator:=arrFilter(f, 2)
End Select
End If
Next intSpalte
Next f
Else
'ggf. gesetzte Filter zurücksetzen
If .ListObjects(1).Autofilter.FilterMode Then .ListObjects(1).Autofilter.ShowAllData
'nun Filter neu setzen
For f = 1 To 6
'richtiges Feld für Filter suchen
For intSpalte = 1 To 6
If .Cells(.ListObjects(1).HeaderRowRange.Row, intSpalte).Value = arrFilter(f, 0) Then
'Filter übertragen
Select Case arrFilter(f, 1)
Case Is = 1
.ListObjects(1).Range.Autofilter Field:=f, Criteria1:=arrFilter(f, 3), Operator:=arrFilter(f, 2)
Case Is = 2
.ListObjects(1).Range.Autofilter Field:=f, Criteria1:=arrFilter(f, 3), Operator:=arrFilter(f, 2), Criteria2:=arrFilter(f, 4)
Case Is > 2
.ListObjects(1).Range.Autofilter Field:=f, Criteria1:=Array(arrFilter(f, 3)), Operator:=arrFilter(f, 2)
End Select
End If
Next intSpalte
Next f
End If
End If
End With
Next i
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
'Abschlussmeldung
MsgBox "Die Filtereinstellungen wurden übertragen.", 64, "Hinweis"
'Variable zurücksetzen
Set myListObject = Nothing
End Sub
Gruß
M.O.
