XL 2019 Ne pas utiliser les MFC

Usine à gaz · 1 Janvier 2023

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.

mapomme · 1 Janvier 2023

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 · 1 Janvier 2023

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

Usine à gaz · 1 Janvier 2023

Bonjour mapomme

Merci pour retour.
Bon sang, c'est magique

sylvanu · 1 Janvier 2023

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

Usine à gaz · 1 Janvier 2023

Bonjour sylvanu

Merci d'être encore là pour moi.
Mes bons vœux pour toi aussi. Prends soin de toi.
Je vais test et je te dirai...
lol, je viens de poster la suite un peu plus difficile me semble-t-il...

Usine à gaz · 1 Janvier 2023

Re sylvanu

ça fonctionne aussi.
Je te remercie

XL 2019 Ne pas utiliser les MFC

Usine à gaz

XLDnaute Barbatruc

Pièces jointes

mapomme

mapomme

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

sylvanu

XLDnaute Barbatruc

Pièces jointes

Usine à gaz

XLDnaute Barbatruc

Usine à gaz

XLDnaute Barbatruc

Discussions similaires