Aus Interesse...
29.06.2016 11:20:19
Michael
Hallo Michael und Uwe!
Bin gestern nicht mehr dazu gekommen, hat mich aber dennoch interessiert. Natürlich sehe ich es für die üblichen Standardfälle wie Uwe: Einmal einen gewünschten Filter aufzeichnen, und dann auf den gewünschten Blättern anwenden.
Aus Interesse wollte ich aber mal schauen, wie weit sich Autofilter-Einstellungen aber "kopieren", d.h. übertragen, lassen. Hier mein Vorschlag dazu:
Zwei Dateien zum Testen (Code in Mappe1, Modul1): https://www.herber.de/bbs/user/106608.zip
Wen's interessiert...
Sub AutoFilterKopieren()
'Überträgt AutoFilter-Einstellungen auf Ziel-Bereich in Ziel-Mappe
'Gleiche Überschriften dürfen in der Position (Ziel vs Quelle) abweichen
'Im Ziel-Bereich nicht vorhandene Überschriften werden ignoriert
'Geht davon aus, dass der Ziel-Bereich eine intakte Liste ist
'----- Anpassen -----
Const ZielMappe As String = "Mappe2.xlsm"
Const ZielBlatt As String = "Tabelle2"
Const QuellBlatt As String = "Tabelle1"
Const StartZelleQ As String = "C5" 'Erste Zelle des gefilterten Quell-Bereichs
Const StartZelleZ As String = "B8" 'Erste Zelle des Ziel-Bereichs
'----- Ende -----
Dim WbQ As Workbook
Dim WbZ As Workbook
Dim WsQ As Worksheet
Dim WsZ As Worksheet
Dim ListeQ As Range
Dim ListeZ As Range
Dim i&, j&
Dim aF()
Set WbQ = ThisWorkbook
If QuellBlatt vbNullString Then
Set WsQ = WbQ.ActiveSheet
Else: Set WsQ = WbQ.Worksheets(QuellBlatt)
End If
With WsQ
Set ListeQ = .Range(.Range(StartZelleQ), .Range(StartZelleQ).End(xlToRight))
If .AutoFilterMode = False Then
MsgBox "Quell-Blatt befindet sich nicht im AutoFilter-Modus!", _
vbCritical, "Abbruch"
Exit Sub
End If
End With
Set WbZ = Workbooks(ZielMappe)
Set WsZ = WbZ.Worksheets(ZielBlatt)
With WsZ
Set ListeZ = .Range(StartZelleZ).CurrentRegion
End With
ReDim aF(1 To ListeQ.Cells.Count, 1 To 4)
For i = 1 To ListeQ.Cells.Count
With ListeQ(i).Parent.AutoFilter
With .Filters(ListeQ(i).Column - .Range.Column + 1)
If .On Then
aF(i, 1) = ListeQ(i).Value
aF(i, 2) = .Criteria1
If .Operator Then
aF(i, 3) = .Operator
aF(i, 4) = .Criteria2
End If
End If
End With
End With
Next i
j = 1
Do Until j > UBound(aF, 1)
If aF(j, 1) vbNullString And _
Not IsError(Application.Match(aF(j, 1), ListeZ.Rows(1), 0)) Then
Select Case aF(j, 4)
Case Is = vbNullString
With ListeZ
.AutoFilter Field:=Application.Match(aF(j, 1), .Rows(1), 0), _
Criteria1:=aF(j, 2)
End With
Case Else
With ListeZ
.AutoFilter Field:=Application.Match(aF(j, 1), .Rows(1), 0), _
Criteria1:=aF(j, 2), Operator:=aF(j, 3), Criteria2:=aF(j, 4)
End With
End Select
End If
j = j + 1
Loop
End Sub
LG
Michael