39 Aufrufe
Gefragt in Tabellenkalkulation von angel Einsteiger_in (11 Punkte)
Bearbeitet von angel

Hallo,

ich hoffe, es kann mir jemand weiterhelfen!

In meiner Arbeitsmappe befinden sich drei Tabellen mit Bedingter Formatierung (Zeilen werden farbig hinterlegt wenn z. Bsp. Urlaub in einer bestimmten Zelle eingefügt wird) die nach bestimmten Kriterien gefiltert werden.

Die Auswertung und das Einfügen in eine neue Tabelle mit VBA (selbst gebastelt) funktioniert.

Die Zeilenfarbe wird leider nicht übernommen, was fehlt bei meinem VBA-Code?
Beispieldatei
Ich sage schon mal Danke für Eure Hilfe!

Angelika

2 Antworten

+1 Punkt
Beantwortet von m-o Profi (16.3k Punkte)
ausgewählt von angel
 
Beste Antwort

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.

0 Punkte
Beantwortet von angel Einsteiger_in (11 Punkte)
Hallo M.O.,

vielen Dank für Deine Mühe, funktioniert prima!

Jetzt kann ich endlich weiter basteln, möchte mir noch eine Eingabemaske erstellen mal sehen, wie weit ich ohne Hilfe komme.

Gruß Angelika
...