XL 2019 Ne pas utiliser les MFC

Usine à gaz

XLDnaute Barbatruc
Supporter XLD
Bonjour à toutes et à tous :)

Dans le fichier joint, j'ai un code :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("j2:j500")) Is Nothing Then
Cells(ActiveCell.Row, 10).Font.Bold = True
If Cells(ActiveCell.Row, 10) = "" Then
    With Cells(ActiveCell.Row, 10).Interior
        .ThemeColor = xlThemeColorDark1
    End With
    With Cells(ActiveCell.Row, 10).Font
        .ColorIndex = xlAutomatic
    End With
End If
If Cells(ActiveCell.Row, 10) = "Annulé" Then
    With Cells(ActiveCell.Row, 10).Interior
        '.Pattern = xlSolid
        '.PatternColorIndex = xlAutomatic
        .Color = 192
        '.TintAndShade = 0
        '.PatternTintAndShade = 0
    End With
    With Cells(ActiveCell.Row, 10).Font
        .ThemeColor = xlThemeColorDark1
        '.TintAndShade = 0
    End With
End If
If Cells(ActiveCell.Row, 10) = "NPR" Then
    With Cells(ActiveCell.Row, 10).Interior
        .Color = 192
    End With
    With Cells(ActiveCell.Row, 10).Font
        .ThemeColor = xlThemeColorDark1
    End With
End If
If Cells(ActiveCell.Row, 10) = "RdV Fait" Then
    With Cells(ActiveCell.Row, 10).Interior
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.499984740745262
    End With
    With Cells(ActiveCell.Row, 10).Font
        .ThemeColor = xlThemeColorDark1
    End With
End If
If Cells(ActiveCell.Row, 10) = "RdV Fait Facturé" Then
    With Cells(ActiveCell.Row, 10).Interior
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.499984740745262
    End With
    With Cells(ActiveCell.Row, 10).Font
        .ThemeColor = xlThemeColorDark1
    End With
End If
End If
'[A1].Select
End Sub
L'objectif est le suivant :
1 - ne pas utiliser les MFC,
2 - Mettre des couleurs de fonds et textes en gras ou non selon le contenu des cellules colonne "J".
- target = vide..........................., cellule col."J" fond couleur BLANC - texte couleur NOIR ET PAS en gras,
- target = NPR..........................., cellule col."J" fond couleur ROUGE - texte couleur BLANC en gras,
- target = RdV Fait....................., cellule col."J" fond couleur VERT - texte couleur BLANC en gras,
- target = RdV Fait Facturé........., cellule col."J" fond couleur VERT - texte couleur BLANC en gras,
- target = Annulé......................., cellule col."J" fond couleur ROUGE - texte couleur BLANC en gras,
Le code fonctionne pour les cellules :
J2 à J5 et j'aimerais le "raccourcir" et je ne sais pas le faire.
Voudriez-vous m'aider pour un code plus court ?
Les cellules J6 à J8 feront l'objet d'un nouveau #post.
Je vous en remercie.
Tous mes voeux de bonheur pour cette nouvelle année, prenez soin de vous.
:)
 

Pièces jointes

  • 0 MFC Fond police_test.xlsm
    204.6 KB · Affichages: 5
Solution
Bonjour et bonne année @Usine à gaz :) ,

Ce code peut-être ? :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xcell
   If Not Intersect(Target, Range("j2:j5")) Is Nothing Then
      Application.ScreenUpdating = False
      For Each xcell In Intersect(Target, Range("j2:j5"))
         xcell.Font.Bold = True
         Select Case LCase(xcell.Value)
            Case "": xcell.Interior.ColorIndex = xlColorIndexAutomatic: xcell.Font.ColorIndex = xlColorIndexAutomatic
            Case "annulé": xcell.Interior.Color = RGB(192, 0, 0): xcell.Font.Color = vbWhite
            Case "npr": xcell.Interior.Color = RGB(192, 0, 0): xcell.Font.Color = vbWhite
            Case "rdv fait": xcell.Interior.Color = RGB(55, 86, 35)...

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonjour et bonne année @Usine à gaz :) ,

Ce code peut-être ? :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xcell
   If Not Intersect(Target, Range("j2:j5")) Is Nothing Then
      Application.ScreenUpdating = False
      For Each xcell In Intersect(Target, Range("j2:j5"))
         xcell.Font.Bold = True
         Select Case LCase(xcell.Value)
            Case "": xcell.Interior.ColorIndex = xlColorIndexAutomatic: xcell.Font.ColorIndex = xlColorIndexAutomatic
            Case "annulé": xcell.Interior.Color = RGB(192, 0, 0): xcell.Font.Color = vbWhite
            Case "npr": xcell.Interior.Color = RGB(192, 0, 0): xcell.Font.Color = vbWhite
            Case "rdv fait": xcell.Interior.Color = RGB(55, 86, 35): xcell.Font.Color = vbWhite
            Case "rdv fait facturé": xcell.Interior.Color = RGB(55, 86, 35): xcell.Font.Color = vbWhite
         End Select
      Next xcell
   End If
End Sub
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour Lionel, MaPomme,
Mes meilleurs vœux pour cette nouvelle et peut être heureuse année.
Comme d'hab, un peu à labour, mais tant qu'à faire puisque c'est fait ....
Du même genre mais peut être plus simple à maintenir dans le cas d'évolutions ... genre usine à gaz. :)
VB:
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
    Application.ScreenUpdating = False
    Blanc = vbWhite: Noir = vbBlack: Rouge = RGB(192, 0, 0): Vert = RGB(56, 87, 35)
    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
    Target.Interior.Color = Couleur
    Target.Font.Color = Texte
    Target.Font.Bold = Gras
End If
End Sub
 

Pièces jointes

  • 0 MFC Fond police_test.xlsm
    193 KB · Affichages: 3

Statistiques des forums

Discussions
313 209
Messages
2 096 238
Membres
106 540
dernier inscrit
Piehas