XL 2019 colorer cellules sans utiliser de MFC (#post2)

[Usine à gaz]

Bonjour à toutes et à tous

Ce #post fait suite à celui-ci : https://excel-downloads.com/threads/ne-pas-utiliser-les-mfc.20072995/#post-20557539
Résolu par mapomme a qui j'adresse un super "MERCI".

Les cellules J6 à J8 sont concernées
Pour ces cellules, j'ai fait des MFC pour les colorer selon leurs contenus :
=ET(H6<>"";CNUM(GAUCHE(H6;10))>AUJOURDHUI())
=ET(H6<>"";CNUM(GAUCHE(H6;10))<AUJOURDHUI())+1
=ET(H6<>"";DATEVAL(STXT(H6;9;2) & "/" & STXT(H6;6;2) & "/" & GAUCHE(H6;4))<=AUJOURDHUI()+1)

Ces MFC fonctionnent et permettent la coloration des cellules selon les dates contenues

Je souhaite ne plus utiliser de MFC et les remplacer par des codes vba mais je n'ai pas trouvé comment les coder.
Voudriez-vous m'aider encore une fois ?
En cas, je joins le fichier test.
Un grand merci à toutes et à tous...

Tous mes vœux de bonheur pour cette nouvelle année, prenez soin de vous.

 

[sylvanu]

Re,
Juste en rajoutant quelques lignes à la macro précédente :

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [J2:J500]) Is Nothing Then
    Dim Couleur, Texte, Gras, Blanc, Noir, Rouge, Vert, Jaune
    Application.ScreenUpdating = False
    Blanc = vbWhite: Noir = vbBlack: Rouge = RGB(192, 0, 0): Vert = RGB(56, 87, 35): Jaune = RGB(255, 255, 204)
    Select Case Target
        Case "":                    Couleur = Blanc: Texte = Noir: Gras = False
        Case "Annulé":              Couleur = Rouge: Texte = Blanc: Gras = True
        Case "NPR":                 Couleur = Rouge: Texte = Blanc: Gras = True
        Case "RdV Fait":            Couleur = Vert: Texte = Blanc: Gras = True
        Case "RdV Fait Facturé":    Couleur = Vert: Texte = Blanc: Gras = True
        Case Else:                  Couleur = Blanc: Texte = Noir: Gras = False
    End Select
    If IsDate(Target) And Target <= Int(Now) + 1 Then
        Couleur = Rouge: Texte = Blanc: Gras = False
    Else
        Couleur = Jaune: Texte = Noir: Gras = False
    End If
    Target.Interior.Color = Couleur
    Target.Font.Color = Texte
    Target.Font.Bold = Gras
End If
End Sub

 

[Usine à gaz]

Re sylvanu
Magic, c'est nickel.
Je te remercie très fort.

 

[sylvanu]

Oups, Ya un bug.
Si ce n'est pas une date alors la mise en forme est jaune, même si un case précédent avait été détecté. Sorry.
Prendre cette PJ.

 

[Usine à gaz]

J'ai vu, enfin je pense.
c'est mieux avec le code modifié :

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [J2:J500]) Is Nothing Then
    Dim Couleur, Texte, Gras, Blanc, Noir, Rouge, Vert, Jaune
    Application.ScreenUpdating = False
    Blanc = vbWhite: Noir = vbBlack: Rouge = RGB(192, 0, 0): Vert = RGB(56, 87, 35): Jaune = RGB(255, 255, 204)
    Select Case Target
        Case "":                    Couleur = Blanc: Texte = Noir: Gras = False
        Case "Annulé":              Couleur = Rouge: Texte = Blanc: Gras = True
        Case "NPR":                 Couleur = Rouge: Texte = Blanc: Gras = True
        Case "RdV Fait":            Couleur = Vert: Texte = Blanc: Gras = True
        Case "RdV Fait Facturé":    Couleur = Vert: Texte = Blanc: Gras = True
        Case Else:                  Couleur = Blanc: Texte = Noir: Gras = False
    End Select
    If IsDate(Target) And Target <= Int(Now) + 1 Then
        Couleur = Rouge: Texte = Blanc: Gras = False
'    Else
'        Couleur = Jaune: Texte = Noir: Gras = False
    End If
    Target.Interior.Color = Couleur
    Target.Font.Color = Texte
    Target.Font.Bold = Gras
End If
End Sub

 

[Usine à gaz]

Oups, Ya un bug.
Si ce n'est pas une date alors la mise en forme est jaune, même si un case précédent avait été détecté. Sorry.
Prendre cette PJ.

En fait, ok, celui-là est nickel,
Encore merci à toi

 

[patricktoulon]

Bonjour
c'est quand même formidable d'utiliser un If isdate..... après un select case
le tout dans un case true ça vous dirais?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [J2:J500]) Is Nothing Then
        Dim Couleur, Texte, Gras, Blanc, Noir, Rouge, Vert, Jaune
        Application.ScreenUpdating = False
        Blanc = vbWhite: Noir = vbBlack: Rouge = RGB(192, 0, 0): Vert = RGB(56, 87, 35): Jaune = RGB(255, 255, 204)

        Select Case True
            Case IsDate(Target) And Target <= Now:: Couleur = Rouge: Texte = Blanc: Gras = True
            Case Target = "": Couleur = Blanc: Texte = Noir: Gras = False
            Case Target = "Annulé": Couleur = Rouge: Texte = Blanc: Gras = True
            Case Target = "NPR": Couleur = Rouge: Texte = Blanc: Gras = True
            Case Target = "RdV Fait": Couleur = Vert: Texte = Blanc: Gras = True
            Case Target = "RdV Fait Facturé": Couleur = Vert: Texte = Blanc: Gras = True
            Case Else: Couleur = Blanc: Texte = Noir: Gras = False
        End Select

        Target.Interior.Color = Couleur
        Target.Font.Color = Texte
        Target.Font.Bold = Gras
    End If
End Sub

 

[patricktoulon]

ou encore on en supprime un et un autre fra pour les deux

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [J2:J500]) Is Nothing Then
        Dim Couleur, Texte, Gras, Blanc, Noir, Rouge, Vert, Jaune
        Application.ScreenUpdating = False
        Blanc = vbWhite: Noir = vbBlack: Rouge = RGB(192, 0, 0): Vert = RGB(56, 87, 35): Jaune = RGB(255, 255, 204)

        Select Case True
            Case IsDate(Target) And Target <= Now:: Couleur = Rouge: Texte = Blanc: Gras = True
            Case Target = "": Couleur = Blanc: Texte = Noir: Gras = False
            Case Target = "Annulé": Couleur = Rouge: Texte = Blanc: Gras = True
            Case Target = "NPR": Couleur = Rouge: Texte = Blanc: Gras = True
            Case InStr(1, Target, "RdV Fait"): Couleur = Vert: Texte = Blanc: Gras = True
            Case Else: Couleur = Blanc: Texte = Noir: Gras = False
        End Select

        Target.Interior.Color = Couleur
        Target.Font.Color = Texte
        Target.Font.Bold = Gras
    End If
End Sub

 

[patricktoulon]

ou bien encore une petite reduction

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, [J2:J500]) Is Nothing Then
        Dim Couleur, Texte, Gras, Blanc, Noir, Rouge, Vert, Jaune
        Application.ScreenUpdating = False
        Blanc = vbWhite: Noir = vbBlack: Rouge = RGB(192, 0, 0): Vert = RGB(56, 87, 35): Jaune = RGB(255, 255, 204)

        Select Case True
            Case (IsDate(Target) And Target <= Now) Or Target = "Annulé" Or Target = "NPR"
                Couleur = Rouge: Texte = Blanc: Gras = True
            Case InStr(1, Target, "RdV Fait"): Couleur = Vert: Texte = Blanc: Gras = True
            Case Else: Couleur = Blanc: Texte = Noir: Gras = False
        End Select

        Target.Interior.Color = Couleur
        Target.Font.Color = Texte
        Target.Font.Bold = Gras
    End If
End Sub

c'est bien le case true je trouve

 

[Usine à gaz]

Bonjour Patrick
Merci pour tes codes.
Je teste dès que possible et je reviendrai te dire.

 

[sylvanu]

Bonjour Lionel, Patrick, et bonne année à tous deux ... et aux autres XLDnautes.
Ca c'est de l'optimisation.
Juste un point qui me chagrine, le Jaune a disparu, cas de la date > à aujourd'hui.

 

[Usine à gaz]

Bonjour sylvanu
"Juste un point qui me chagrine, le Jaune a disparu, cas de la date > à aujourd'hui."
Effectivement, je viens de le voir aussi.

 

[sylvanu]

Il suffit de rajouter :

Case (IsDate(Target) And Target > Now): Couleur = Jaune: Texte = Noir: Gras = False

C'était juste pour la taquinerie en ce début d'année.

 

[Usine à gaz]

OUI mais j'en ai besoin de ce "jaune" lol