In totaal overzicht gekleurde cellen niet meenemen

[sb17]

Beste helpers,

Dmv een makro maak ik een totaal overzicht op sheet 'Totaal Overzicht' van werkbladen met een sheetnaam van 3 tekens( in mijn geval maand afkortingen) waarbij alle gevulde cellen worden gekopieerd en geplakt, maar nu wil ik via een 2e opdracht knop hetzelfde doen alleen dan alle rijen die de kleur hebben van cel p1 in in sheet 'Totaal Overzicht' niet meenemen. Kan iemand aangeven hoe dit kan? De code die ik nu gebruik is:

Sub MakeTotalOverView()
        With Application
            .ScreenUpdating = False
            Sheets("Totaal Overzicht").UsedRange.Offset(1).ClearContents
        
            For Each sh In ThisWorkbook.Sheets
                If Len(sh.Name) = 3 Then
                    lastrow = sh.Range("b" & Rows.Count).End(xlUp).Row
                    If lastrow > 8 Then
                        sh.Range("b8", "o" & lastrow).Copy
                        Sheets("Totaal Overzicht").Range("a" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial Paste:=xlPasteValues
                    End If
                End If
            Next sh
            .Goto Sheets("Totaal Overzicht").[A1]
            .CutCopyMode = False
            
        End With
    With Sheets("Totaal Overzicht")
    
        Sheets("Totaal Overzicht").Range("a:a").NumberFormat = "dd-mm-yyyy"
    End With
   ScreenUpdating = True
End Sub

Alvast bedankt voor de moeite

Siebe

 

[snb]

Waarom plaats je geen voorbeeldbestand ?

Het lijkt erop dat je een oplossing zoekt voor een door jouzelf gecreëerd probleem: de splitsing van analoge gegevens naar 12 werkbladen.
Hier geeft men altijd het advies gelijksoortige gegevens in één werkblad onder te brengen.
Het maken van selekties per maand is dan een fluitje van een cent.

 

[sb17]

beste snb,

Hierbij het voorbeeld bestand.

Het bestand waar ik dit in gebruik is een soort kasboek met voor alle maanden een tabblad. Het verzamelen van de gegevens is opzich niet het probleem maar het uitsluiten van de gele rijen lukt mij even niet.

Siebe

Bekijk bijlage Totaal Overzicht.xlsm

 

[VenA]

Sub VenA()
  For Each sh In Sheets
    If Len(sh.Name) = 3 Then
      With sh.Cells(7, 2).CurrentRegion
        .AutoFilter 1, , xlFilterNoFill
        .Offset(1).Copy Sheets("Totaal Overzicht").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
      End With
    End If
  Next sh
End Sub

 

[sb17]

Beste V en A,

Dank voor je code, werkt goed, maar als ik in mijn eigen code het stukje van jou implementeer lukt het me niet het goed werkend te krijgen, Kun je aangeven hoe ik jou stukje in mijn code kan plaatsen zodat het enige verschil de selectie van gekleurde rijen is?

Siebe

 

[VenA]

Kan je aangeven hoe je het geïmplementeerd hebt? Het lijkt mij vrij duidelijk wat waar moet komen.

 

[sb17]

VenA,

Op deze manier:

Sub MakeTotalOverViewexcolor()
        With Application
            .ScreenUpdating = False
            Sheets("Totaal Overzicht").UsedRange.Offset(1).ClearContents
        
            For Each sh In Sheets
    If Len(sh.Name) = 3 Then
      With sh.Cells(7, 2).CurrentRegion
        .AutoFilter 1, , xlFilterNoFill
        .Offset(1).Copy Sheets("Totaal Overzicht").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        .AutoFilter
      End With
    End If
  Next sh
            .Goto Sheets("Totaal Overzicht").[A1]
            .CutCopyMode = False
            
        End With
    With Sheets("Totaal Overzicht")
    
        Sheets("Totaal Overzicht").Range("a:a").NumberFormat = "dd-mm-yyyy"
    End With
   ScreenUpdating = True
End Sub

In voorbeeld bestand werkt dat wel alleen in originele bestand niet, krijg dan foutmelding in regel;

.Offset(1).Copy Sheets("Totaal Overzicht").Cells(Rows.Count, 1).End(xlUp).Offset(1)

Er worden in het origineel ook gegevens van/boven rij 7 gekopieerd, dat is niet de bedoeling
Bedoeling is dat de gegevens onder rij 7 uit de kolommen B t/m O Gekopieerd worden naar 'Totaal Overzicht'

Hopelijk kun je hier iets mee
Siebe

Bekijk bijlage Totaal Overzicht geimplementeerd.xlsm

 

[VenA]

Wat hebben we aan een voorbeeldbestand wat qua lay-out niet hetzelfde is als het origineel? Waarom plaats je nogmaals het bestand waarin de code wel werkt?

With sh.Range("B7:O" & sh.Cells(Rows.Count, 2).End(xlUp).Row)

 

[sb17]

Beste V en A,

Het originele bestand is te groot om te plaatsen vandaar dat ik een voorbeeld had gemaakt. Na enig knutselwerk is het me gelukt om het werkend te krijgen, dank voor je aanvullende code, dit werkt juist.

Siebe