voorwaardelijke opmaak via vba aanbrengen in meerdere worksheets

[ikselle]

DOEL : de voorwaardelijke opmaak zoals die in cel B19 manueel werd aangebracht mits vba te kopieren naar de range C19:F19 en daarna de range B19:F19 te kopieren naar een 60-tal andere sheets.
OPZET: de bedoeling is in A19 het weekwerkregime aan te passen en in rij 19 aan de hand van de kleur te kunnen zien of er of afwezigheden mogelijk zijn
Rood = te veel, oranje = stop en groen = ok
PROBLEMEN:
1. fout in code (voorlopig met knop)
2. op dit moment wordt de kleur in B19 bepaald door het overeenkomstig kleurenwoord. Beter zou het zijn om het resultaat van de formule de kleur te laten bepalen.
3. de gegevensvalidatie uit A19 zou ook mee gekopieerd moeten worden
Heeft hier iemand ervaring mee?
Alvast bedankt.

 

[JanBG]

Hallo,

Zo iets?

Sub Macro1()
    Range("B19").Copy
    Range("C19:F19").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

    Range("B19:F19").Copy
    Sheets("Blad3").Range("B19").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
        xlNone, SkipBlanks:=False, Transpose:=False
    Sheets("Blad3").Range("B19").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
End Sub

 

[ikselle]

Bedankt JanBG, maar met jouw code krijg ik de waarden uit de cellen B19:F19 in blad3. M.a.w. de regels van de voorwaardelijke opmaak worden niet gekopieerd. Ik meende wel dat je me op de goede weg kon zetten en probeerde het met :

Range("B19:F19").Copy
Sheets("Blad3").Range("B19").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:= _
                                             xlNone, SkipBlanks:=False, Transpose:=False

Nu bekwam ik in blad3 de formules maar nog steeds geen opmaak.

 

[VenA]

Hoe ziet het niet vindbare tabje 'Blad3' eruit? Wat is het nut van deze exercitie? Je hebt allemaal versnipperde validatieregels staan. Moet je deze niet eerst even opschonen?

 

[ikselle]

VenA
De bedoeling is om de voorwaardelijke opmaak uit blad1 uit range A19:F19 te kopieren naar meerdere bladen (zestigtal).
En inderdaad hierbij de opgeschoonde versie.

 

[JanBG]

In dit bestandje werkt het prima

 

[VenA]

Waarom eenduidige gegevens op 62 tabjes? Lijkt mij meer iets dat je in 1 tabel invoert. Daarnaast heb je in Blad1 een keuzelijst staan en maak je gebruik van een tabelletje In de andere tabjes niet. Moeten de formules in de andere tabjes ook refereren aan dit tabelletje(tabSch)? In mijn optiek een slechte opzet en ik heb niet echt een idee wat het moet worden. Kan dus ook geen verbeteringen aanbrengen.

 

[ikselle]

VenA en JanBG bedankt! Heb het opgelost door de voorwaardelijke formattering in blad1 aan te passen en dan

Sub KleurenGeven()
   Dim ws As Worksheet
   Dim t As Integer
   For t = 2 To Worksheets.Count
      Sheets("Blad1").Select
      Range("A19:F19").Select
      Application.CutCopyMode = False
      Selection.Copy
      Sheets("Blad" & t).Select
      Range("A19").Select
      ActiveSheet.Paste
      Application.CutCopyMode = False
   Next
End Sub

Simpel maar soms ligt de oplossing voor de hand

 

[VenA]

Alle selects en selections kan je weglaten.

Sub KleurenGeven()
  Dim t As Integer
  For t = 2 To Worksheets.Count
    Sheets("Blad1").Range("A19:F19").Copy Sheets("Blad" & t).Range("A19")
  Next
End Sub

 

[ikselle]

Bedankt VenA