Voorwaardelijke opmaak met VBA

adile · 15 jan 2016

Goedemorgen,

Ik heb een bestand, waarin ik veel gebruik maak van voorwaardelijke opmaak. maar ik merkte dat wanneer ik veel kopieer/knip en plak, het bestand erg groot wordt en de leest met voorwaardelijke opmaak heel lang wordt. dus ik heb gezocht naar een code om dit via VBA te doen. daarvoor heb ik uiteindelijk de onderstaande code gebouwd.
de code werkt, maar ik stuit op 2 probleempjes.
1 ik wil dat de code werkt voor losse ranges, de ranges die in het rood staan aangegeven, maar op de manier hoe ik het doe werkt het niet.
2 de code zorgt ervoor dat het bestand traag werkt (bij elke wijziging krijg ik het welbekende zandloperdje) is er een mogelijkheid de code sneller te laten werken?

Code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)


'
' Statuskleuren_toevoegen Macro
'
Dim x As Range
    [COLOR="#FF0000"]"For Each x In ActiveSheet.Range("$C$6:$BF$16", "$C$18:$BF$25", "$C$27:$BF$34", "$C$6:$BF$102", "$C$36:$BF$143", "$C$45:$BF$51", "$C$54:$BF$83", "$C$85:$BF$102", "$BO$6:$BO$102")"[/COLOR]
    For Each x In ActiveSheet.Range("$C$6:$BF$102", "$BO$6:$BO$102")
    With x
   
    Select Case .Value
      Case Is = "Rec V1 /ACA"
          .Interior.ColorIndex = 33
          .Font.ColorIndex = 1
      Case Is = "Rec V2"
          .Interior.ColorIndex = 21
          .Font.ColorIndex = 2
      Case Is = "Rec L"
          .Interior.ColorIndex = 31
          .Font.ColorIndex = 2
      Case Is = "Ziek"
          .Interior.ColorIndex = 52
          .Font.ColorIndex = 2
      Case Is = "VL"
          .Interior.ColorIndex = 7
          .Font.ColorIndex = 1
      Case Is = "CAO VL"
          .Interior.ColorIndex = 7
          .Font.ColorIndex = 1
      Case Is = "Uitleen"
          .Interior.ColorIndex = 35
          .Font.ColorIndex = 10
      Case Is = "Event"
          .Interior.ColorIndex = 33
          .Font.ColorIndex = 1
      Case Is = "Cursus"
          .Interior.ColorIndex = 10
          .Font.ColorIndex = 2
      Case Is = "Ruiling"
          .Interior.ColorIndex = 12
          .Font.ColorIndex = 2
      Case Is = "Admin"
          .Interior.ColorIndex = 38
          .Font.ColorIndex = 1
      Case Is = "N-B"
          .Interior.ColorIndex = 15
          .Font.ColorIndex = 1
      Case Is = "Vervang"
          .Interior.ColorIndex = 13
          .Font.ColorIndex = 2
      Case Is = "EHBO"
          .Interior.ColorIndex = 42
          .Font.ColorIndex = 2
      Case Is = "O-1e CRO"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "O-PBHV"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "O-CRO"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "O-G"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "O-G+"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "O-G ex"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "Exp"
          .Interior.ColorIndex = 39
          .Font.ColorIndex = 1
      Case Is = "M-1e CRO"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-CRO"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-PBHV"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-G"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-G ex"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-G ex2"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-P M"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "M-P A"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "N-1e CRO"
          .Interior.ColorIndex = 5
          .Font.ColorIndex = 2
      Case Is = "N-PBHV"
          .Interior.ColorIndex = 5
          .Font.ColorIndex = 2
      Case Is = "N-CRO"
          .Interior.ColorIndex = 5
          .Font.ColorIndex = 2
      Case Is = "N-G ex"
          .Interior.ColorIndex = 5
          .Font.ColorIndex = 2
      Case Is = "N-G ex2"
          .Interior.ColorIndex = 5
          .Font.ColorIndex = 2
      Case Is = "TV D"
          .Interior.ColorIndex = 40
          .Font.ColorIndex = 52
      Case Is = "TV A"
          .Interior.ColorIndex = 40
          .Font.ColorIndex = 52
      Case Is = "TV N"
          .Interior.ColorIndex = 40
          .Font.ColorIndex = 52
      Case Is = "Uitl D"
          .Interior.ColorIndex = 35
          .Font.ColorIndex = 10
      Case Is = "Uitl A"
          .Interior.ColorIndex = 35
          .Font.ColorIndex = 10
      Case Is = "Uitl N"
          .Interior.ColorIndex = 35
          .Font.ColorIndex = 10
      Case Is = "O-CRO I"
          .Interior.ColorIndex = 19
          .Font.ColorIndex = 1
      Case Is = "M-CRO I"
          .Interior.ColorIndex = 50
          .Font.ColorIndex = 2
      Case Is = "BBM"
          .Interior.ColorIndex = 37
          .Font.ColorIndex = 2
      Case Is = "SSV"
          .Interior.ColorIndex = 39
          .Font.ColorIndex = 1
      Case Is = "Coach"
          .Interior.ColorIndex = 10
          .Font.ColorIndex = 2
      Case Is = "VCA G4S"
          .Interior.ColorIndex = 42
          .Font.ColorIndex = 1
      Case Is = "G-Supp"
          .Interior.ColorIndex = 38
          .Font.ColorIndex = 1
      Case Is = "Recp8"
          .Interior.ColorIndex = 40
          .Font.ColorIndex = 1
      Case Is = "Recp9"
          .Interior.ColorIndex = 40
          .Font.ColorIndex = 1
      Case Is = "Overleg"
          .Interior.ColorIndex = 3
          .Font.ColorIndex = 2
      Case Is = "Reserve"
          .Interior.ColorIndex = 15
          .Font.ColorIndex = 1
      Case Is = "HSE"
          .Interior.ColorIndex = 16
          .Font.ColorIndex = 2
      Case Is = "Verkeer"
          .Interior.ColorIndex = 45
          .Font.ColorIndex = 1
      Case Is = "Gpl Sell"
          .Interior.ColorIndex = 6
          .Font.ColorIndex = 1
      Case Is = "Gpl Sell-"
          .Interior.ColorIndex = 6
          .Font.ColorIndex = 1
      Case Is = "VIR"
          .Interior.ColorIndex = 17
          .Font.ColorIndex = 1
      Case Is = "OR"
          .Interior.ColorIndex = 48
          .Font.ColorIndex = 1
      Case Is = ""
          .Interior.ColorIndex = 2
          .Font.ColorIndex = 1
          


    End Select

   End With
   Next

  End Sub

edmoor · 15 jan 2016

En dat moet echt bij een wijziging in iedere cel gebeuren?

Tevens gebruik je veel dezelfde kleur combinaties voor verschillende Case controles. Die kan je beter combineren. Bijvoorbeeld:

Code:

Case "M-1e CRO", "M-CRO", "M-PBHV", "M-G", "M-G ex", "M-G ex2", "M-P M", "M-P A"
      .Interior.ColorIndex = 50
      .Font.ColorIndex = 2

Peter B · 15 jan 2016

De code wordt nu iedere keer uitgevoerd bij een wijziging van de selectie. Ik zou hem veranderen zodanig dat hij alleen wordt afgevuurd als de cel-inhoud wordt gewijzigd (dus event Worksheet_Change). Vervolgens kun je controleren of de gewijzigde cel in de aangegeven range valt. En pas dan hoef je m.i. voor die ene cel te controleren of de formatting moet wijzigen. Maar zonder echt voorbeeldbestand is dat niet te controleren.

N.B. Om de formatting initiëel goed te zetten kun je bv. met het event Worksheet_Activate de code bij activeren van de sheet éénmalig laten draaien (of misschien zelfs wel bij openen van het openen van het workbook, dus event Workbook_Open).

Hopelijk helpt dit?

adile · 16 jan 2016

Heren,

Thanx voor de input, ik heb sommige gedeeltes samengevoegd, maar dat

@edmoor,
ik heb wat gedeeltes samen gevoegd maar dat haalde niet heel veel uit.ik nu wel makkelijker kleuren toe te voegen bedankt daarvoor.
en in principe hoeft de code alleen de eerste keer betrekking te hebben op de hele sheet, daarna mag hij ook werken op de cellen die worden aangepast.

@Peter
over het gedeelte selection change, dat is gewoon de macro in de module. de macro staat in de module en wordt geactiveerd door de volgende code in het tabblad.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Statuskleuren_toevoegen
  Statuskleuren_toevoegen2
End Sub

en dat is dus wel worksheet change.

ik heb worksheet activate geprobeerd, maar dan is het iedere keer als ik naar een andere sheet ga moet ik 10 seconden of meer wachten totdat alle kleuren geladen zijn.

ik heb een voorbeeld van het bestand bijgevoegd.

Adile

Cobbe · 16 jan 2016

Deze lijkt mij toch een klein beetje logischer.
Waarom springen naar een module?

En telkens een for - Next lus remt natuurlijk af.

zapatr · 16 jan 2016

@adile
Je topictitel luidt: "Voorwaardelijk opmaak via VBA".
Maar in de code die je daarbij plaatst is helemaal geen sprake van voorwaardelijke opmaak in de betekenis die Excel daar aan geeft, maar van gewone opmaak !

adile · 16 jan 2016

Cobbe,

Veel dank voor je hulp.
Hij werkt inderdaad een heel stuk sneller op jouw manier. alleen moet ik het onderste gedeelte waar ik de 0,1,2 en 3 een kleur geef loskoppelen. dit heeft namelijk alleen betrekking op de range C104:BF123, dit is een controle of ik codes er dubbel/helemaal niet in heb staan.
en een laatste puntje, dan denk ik dat ik de code af is, als ik bv 4 cellen kopieer en plak in een andere range dan krijg ik een foutmelding, weet jij dit te omzeilen?

@Zapatr

Ik wil dat de kleuren in de cellen veranderen op basis van de tekst die in de cel staat, mij lijkt dat een voorwaardelijke opmaak.
maar misschien dat de definitie in excel anders is. Als dat zo is excuses daarvoor.

Adile

zapatr · 16 jan 2016

@adile,
je hoeft je tegenover mij niet te excuseren, want mij maakt dat niet uit, jíj bent het die er mee moet werken.
Jouw methode is wel voorw. opmaak volgens de regels van de Nederlandse taal, maar niet volgens die van Excel. Maar jij denkt waarschijnlijk: "Wat maakt mij dat uit, als de code maar doet wat ze moet doen", en dat is een goede instelling. Wil je zien wat voor Excel het verschil is tussen wel en geen voorw. opmaak, geef dan, met de macrorecorder aan, bepaalde cellen maar eens een kleur mét voorw. opmaak en zonder.

Cobbe · 16 jan 2016

Dan splits je deze blokken toch.

adile · 16 jan 2016

Cobbe,

Ik heb hem nu in gesplitst, Top!
Omdat ik veel kopieer en plak in het bestand, dient het ook te werken wanneer ik zeg maar een hele rij Exp naar een andere rij kopieer.
alleen krijg ik dan een foutmelding.
Ook veranderd de kleur in de dubbel controle in C104:BF123 niet direct, ik moet dan een verandering in de cel zelf maken*door bv dubbel te klikken) voordat deze van kleur veranderen. Kan dit direct? bij mijn eerste voorbeeld dat zo traag was deed hij dit nog wel.

@zapatr, ik zal dat eens proberen en kijken wat het verschil is dank je.

Adile

Cobbe · 16 jan 2016

Zet in A1 bv deze formule en verberg ze indien gewenst met fontkleur wit:

Code:

=aantal.als(C6:BF102;"VL")

Deze zorgt ervoor dat bij elke wijziging er gerekend wordt en zo wordt de celwijziging behandeld.

edmoor · 16 jan 2016

aanTal.als

VenA · 16 jan 2016

Zelf zou ik alle Case selects er uit gooien en de parameters in een aparte sheet zetten. Dit maakt het beheer een stuk eenvoudiger en de code een stuk korter.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$C$6:$BF$102,$C$104:$BF$124")) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    ar = Sheets("Dienstkleur").Cells(1).CurrentRegion
    With Target
        For j = 1 To UBound(ar)
            If ar(j, 1) = .Value Then
               .Interior.ColorIndex = ar(j, 2)
               .Font.ColorIndex = ar(j, 3)
               Exit For
            End If
        Next j
  End With
  Application.EnableEvents = True
End If
End Sub

adile · 16 jan 2016

@Cobbe,

als ik die formule in A1 zet dan wil hij het nog niet doen helaas.

@V&A,
jouw manier is idd ook wel handig, maar hoe moet ik de code schrijven zodat onderstaande gedeelte van de code alleen betrekking heeft op $C$104:$BF$124"
1 6 2
0 45 45
2 3 3
3 3 3

dit zijn 2 losse delen. en dit "controle" deel werkt ook in jouw bestand niet direct na een aanpassing in het bestand.

Adile

VenA · 16 jan 2016

Ik denk dat je deze formule eens moet analyseren staat in C104

PHP:

=ALS(IS.ONEVEN(KOLOM());AANTAL.ALS(C$6:C$102;$BO11);-1)

Plaats ook een voorbeeldje zonder koppelingen naar andere bestanden of tabjes die er niet instaan. De keuzelijstjes werken nu niet waardoor het lastig te testen is of iets werkt.

adile · 16 jan 2016

V&A

Ik heb het bestand toegevoegd met de keuzelijsten erin.
De code in C104 werkte in mijn "Trage" eerste voorbeeldbestand wel gewoon.
de kleur veranderde automatisch in het onderste blok als er iets dubbel in stond of wanneer ik een naam vergeten was.

en omdat het onderste gedeelte "$C$104:$BF$124"een controle is op wat er in "$C$6:$BF$102" gebeurt dient dit in de vba code van elkaar los gekoppeld te worden.
wat moet ik aanpassen in jouw code wanneer ik onderstaande gegevens in Kolommen D, E en F zet?
1 6 2
0 45 45
2 3 3
3 3 3

Adile

adile · 17 jan 2016

V&A,

Ik heb het tweede probleempje getackelt, en de code aangepast in onderstaande code.
Ik zit alleen nog met het probleem dat hij het gedeelte C104:BF124 dat dmv een formule wordt gewijzigd niet automatisch veranderd.
en het gedeelte tussen C6:BF104 waarin ik handmatig wijzig de kleur wel automatisch gewijzigd wordt.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$C$6:$BF$102,$C$104:$BF$124")) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    ar = Sheets("Dienstkleur").Cells(1).CurrentRegion
    With Target
        For j = 1 To UBound(ar)
            If ar(j, 1) = .Value Then
               .Interior.ColorIndex = ar(j, 2)
               .Font.ColorIndex = ar(j, 3)
               Exit For
            End If
        Next j
  End With
  Application.EnableEvents = True
End If
If Not Intersect(Target, Range("$C$104:$BF$123")) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    ar = Sheets("Dienstkleur").Cells(1).CurrentRegion
    With Target
        For j = 1 To UBound(ar)
            If ar(j, 4) = .Value Then
               .Interior.ColorIndex = ar(j, 5)
               .Font.ColorIndex = ar(j, 6)
               Exit For
            End If
        Next j
  End With
  Application.EnableEvents = True
End If
End Sub

Adile

VenA · 17 jan 2016

Jouw tweede Intersect wordt nooit aangeroepen.

Zo gaat het volgens mij wel goed.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("$C$6:$BF$102")) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    ar = Sheets("Dienstkleur").Cells(1).CurrentRegion
    With Target
        For j = 1 To UBound(ar)
            If ar(j, 1) = .Value Then
               .Interior.ColorIndex = ar(j, 2)
               .Font.ColorIndex = ar(j, 3)
               Exit For
            End If
        Next j
        For Each cl In Range("B103:B123").Offset(, .Column - 2)
            For j = 1 To UBound(ar)
                If ar(j, 1) = cl.Value Then
                    cl.Interior.ColorIndex = ar(j, 2)
                    cl.Font.ColorIndex = ar(j, 3)
                    Exit For
                End If
            Next j
        Next cl
    End With
  Application.EnableEvents = True
End If

snb · 17 jan 2016

ik veel gebruik maak van voorwaardelijke opmaak. maar ik merkte dat wanneer ik veel kopieer/knip en plak, het bestand erg groot wordt

Het probleem is dus dat je het werkblad waarin gegevens worden opgeslagen ook als invoerscherm en als presentatiescherm gebruikt.
Dat kun je beter splitsen. Het gebruik van een userform ligt dan voor de hand.

adile · 17 jan 2016

V&A,

als ik jouw laatste code gebruik, en ik zet als voorbeeld een dubbele waarde in een kolom, dan worden alle rijen (104:123) van de betreffende kolom wit.
terwijl dan 1 cel juist rood dient te worden.

@ snb
wat je zegt klopt wel, maar ik heb 13 sheets die uit 1 sheet de informatie halen, de 12 andere sheets waar de data niet in staat opgeslagen die worden ook steeds groter en groter.
dwz de rij met voorwaardelijke opmaken wordt gigantisch lang.

Adile

Voorwaardelijke opmaak met VBA

Gebruiker

Inventaris

Gebruiker

Gebruiker

Bijlagen

Giga Honourable Senior Member †

Bijlagen

Terugkerende gebruiker

Gebruiker

Terugkerende gebruiker

Giga Honourable Senior Member †

Bijlagen

Gebruiker

Giga Honourable Senior Member †

Inventaris

Inventaris

Bijlagen

Gebruiker

Inventaris

Gebruiker

Bijlagen

Gebruiker

Inventaris

Verenigingslid

Gebruiker

Wij waarderen jouw privacy