verschillende tabladden met dezefde voorwaardelijke opmaak adhv formule

[plainme]

Beste Amici,

heb nog een vraagje inzake voorwaardelijke opmaak....

Bestaat er een mogelijkheid om met een bepaalde VB script 52 tabbladen met één en dezelfde voorwaardelijke opmaak aan te sturen.

volgende doet zich hier voor.


Ik heb 52 verschillende tabbladen die adhv van 3 cijfers ( nml 1 - 2 - 3 ( 1 = groene kleur - 2 = rode kleur - 3 = blauwe kleur)) het bereik van kolom B tem kolom M dienen in te kleuren wanneer er een waarde (cijfer of 1 of 2 of 3) is ingegeven. Het cijfer komt in kolom G te staan .
Het bereik start vanaf B6 en loopt tot M500.

U kan zich al gaan inbeelden dat met 3 cijfers hier de lange winteravonden zullen gevuld zijn. Ik denk dat dat dit via een script een stuk vlugger kan zodat een mens ook nog kan genieten van de open haard

Alvast bedankt voor het meedenken en een eventuele oplossing

 

[edmoor]

Zet deze in de ThisWorkbook sectie:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Target.Column = 7 And Target.Row > 5 And Target.Row <= 500 Then
        Dim Kleur As Long
        
        Select Case Target.Value
            Case 1:     Kleur = 5287936  'Groen
            Case 2:     Kleur = 255      'Rood
            Case 3:     Kleur = 12611584 'Blauw
            Case Else:  Kleur = xlNone
        End Select
        
        Range("B" & Target.Row & ":M" & Target.Row).Interior.Color = Kleur
    End If
End Sub

Veel plezier bij de open haard gewenst

Edit:
Mij is niet duidelijk of die cijfers al ingevuld zijn of dat dat nog moet gebeuren.
Bovenstaande code werkt als je de cijfers in kolom G gaat invullen, niet als deze al gevuld zijn.
Mocht je dat anders willen dat laat het hier maar even weten.

 

[VenA]

Als oneliner

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
  If Target.Column = 7 And Target.Row > 5 And Target.Row <= 500 Then Target.Offset(, -5).Resize(, 12).Interior.Color = Application.IfError(Application.Choose(Target.Value, vbGreen, vbRed, vbBlue), xlNone)
End Sub

Of als het hele bestand onder handen genomen moet worden

Sub VenA()
Dim cl As Range, sh As Object
With Application
  .ScreenUpdating = False
  For Each sh In Sheets
    For Each cl In sh.Range("G6:G500")
      cl.Offset(, -5).Resize(, 12).Interior.Color = .IfError(.Choose(cl.Value, vbGreen, vbRed, vbBlue), xlNone)
    Next cl
  Next sh
End With
End Sub

 

[plainme]

Beste Edmoor, VenA

Beide werken super !!!!!
@Edmoor -> getallen moeten nog ingevuld worden zodoende ..... Super
@VenA die van jou werkt in beide richtingen leeg en ingevuld zodoende .... Super


Dat wordt genieten van de haard zie

Nog een fijne zondag iedereen en nogmaals een dikke bedankt.