Hallo Angelika,
wenn du mit dem Spezialfilter kopierst, wird ohne Formatierungen kopiert. Setze den Spezialfilter und kopiere dann die gefilterten Datensätze.
Probier es mal so:
Sub Mehrere_Listen_Filtern_Format()
'
' Mehrere_Listen_Filtern Makro
' Auswertung_Stunden
'
'
Dim lngLastRowMO As Long
Dim lngLastGR As Long
Dim lngLastRowFI As Long
Dim lngLastRowKR As Long
Dim lngLastRow As Long
Dim rngSuche As Range
'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False
lngLastRowMO = Sheets("Moy").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowGR = Sheets("Grieser").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowFI = Sheets("Fiori").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRowKR = Sheets("Kriterien").Cells(Rows.Count, 1).End(xlUp).Row
lngLastRow = Sheets("Kundenauswertung").Cells(Rows.Count, 1).End(xlUp).Row
'Suchbereich festlegen
Set rngSuche = Worksheets("Moy").Range("A1:I" & lngLastRowMO)
'Mit Spezialfilter an Ort und Stelle filtern
rngSuche.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Worksheets("Kriterien").Range("A1:A" & lngLastRowKR)
'Gefilterte Datensätze ins Tabellenblatt Kundenauswertung kopieren
rngSuche.Copy Destination:=Worksheets("Kundenauswertung").Range("A1")
'Im gefilterten Arbeitsblatt wieder alle Daten anzeigen
Worksheets("Moy").ShowAllData
lngLastRow = Worksheets("Kundenauswertung").Cells(Rows.Count, 1).End(xlUp).Row
Set rngSuche = Worksheets("Grieser").Range("A1:I" & lngLastRowGR)
rngSuche.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Worksheets("Kriterien").Range("A1:A" & lngLastRowKR)
rngSuche.Copy Destination:=Worksheets("Kundenauswertung").Range("A" & lngLastRow + 1)
Worksheets("Grieser").ShowAllData
lngLastRow = Worksheets("Kundenauswertung").Cells(Rows.Count, 1).End(xlUp).Row
Set rngSuche = Worksheets("Fiori").Range("A1:I" & lngLastRowFI)
rngSuche.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Sheets("Kriterien").Range("A1:A" & lngLastRowKR)
rngSuche.Copy Destination:=Worksheets("Kundenauswertung").Range("A" & lngLastRow + 1)
Worksheets("Fiori").ShowAllData
'Suchbereich zurück setzen
Set rngSuche = Nothing
Worksheets("Kundenauswertung").Activate
Range("A1").Select
'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True
End Sub
Gruß
M.O.