XL 2016 simplifier une macro enregistrée

dindin

XLDnaute Occasionnel
Bonjour,
Comment faire pour simplifier cette macro enregistrée
VB:
Sub couleur()
'
' couleur Macro

    Range("D15:j200").Select
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""CA"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent5
        .TintAndShade = 0
    End With
   
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""RTT"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0
    End With
   
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="=""CR"""
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent3
        .TintAndShade = 0
    End With
 
End Sub
c'est une liste de 7 choix, donc en MFC c'est trop long
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Dinidin,
A essayer :
VB:
Sub Couleur()
    Set Plage = Range("D15:j200")
    Plage.FormatConditions.Delete
    Texte = "CA":   Fond = xlThemeColorAccent5: MFC Plage, Texte, Fond
    Texte = "RTT":  Fond = xlThemeColorAccent6: MFC Plage, Texte, Fond
    Texte = "CR":   Fond = xlThemeColorAccent3: MFC Plage, Texte, Fond
End Sub
Sub MFC(Plage, Texte, Fond)
    With Plage
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=Texte
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.ThemeColor = Fond
    End With
End Sub
Pour rajouter une MFC il suffit de rajouter dans Couleur la ligne :
Code:
Texte = "TEXTE":   Fond = COULEUR: MFC Plage, Texte, Fond
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Ou peut être plus simple, à vous de voir :
VB:
Sub Couleur2()
    Range("D15:J200").FormatConditions.Delete
    MFC2 "CA", xlThemeColorAccent5
    MFC2 "RTT", xlThemeColorAccent6
    MFC2 "CR", xlThemeColorAccent3
End Sub
Sub MFC2(Texte, Fond)
    With Range("D15:J200")
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=Texte
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.ThemeColor = Fond
    End With
End Sub
 

dindin

XLDnaute Occasionnel
Ou peut être plus simple, à vous de voir :
VB:
Sub Couleur2()
    Range("D15:J200").FormatConditions.Delete
    MFC2 "CA", xlThemeColorAccent5
    MFC2 "RTT", xlThemeColorAccent6
    MFC2 "CR", xlThemeColorAccent3
End Sub
Sub MFC2(Texte, Fond)
    With Range("D15:J200")
        .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, Formula1:=Texte
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        .FormatConditions(1).Interior.ThemeColor = Fond
    End With
End Sub
Bonjour sylvanu,
Merci beaucoup
 

Staple1600

XLDnaute Barbatruc
Bonjour le fil

Une autre syntaxe posssible
VB:
Sub test()
MFC_3 Range("D15:J20")
End Sub

Private Function MFC_3(Rng As Range)
Dim c
c = Array(Array("CA", 3), Array("RTT", 6), Array("CR", 12))
Rng.FormatConditions.Delete
For i = LBound(c) To UBound(c)
Rng.FormatConditions.Add Type:=1, Operator:=3, Formula1:=c(i)(0)
Rng.FormatConditions(i + 1).Interior.ColorIndex = c(i)(1)
Next
End Function
Faire les adaptations nécessaires pour Excel 2016.
(Car test effectué sur Excel 2003 et Excel 2003 ne connait pas cette syntaxe xlThemeColorAccent5)

@sylvanu
Si tu as le temps et la gentilesse de faire la transcription et le test sur un Excel plus récent, merci ;)
 

dindin

XLDnaute Occasionnel
Bonjour le fil

Une autre syntaxe posssible
VB:
Sub test()
MFC_3 Range("D15:J20")
End Sub

Private Function MFC_3(Rng As Range)
Dim c
c = Array(Array("CA", 3), Array("RTT", 6), Array("CR", 12))
Rng.FormatConditions.Delete
For i = LBound(c) To UBound(c)
Rng.FormatConditions.Add Type:=1, Operator:=3, Formula1:=c(i)(0)
Rng.FormatConditions(i + 1).Interior.ColorIndex = c(i)(1)
Next
End Function
Faire les adaptations nécessaires pour Excel 2016.
(Car test effectué sur Excel 2003 et Excel 2003 ne connait pas cette syntaxe xlThemeColorAccent5)

@sylvanu
Si tu as le temps et la gentilesse de faire la transcription et le test sur un Excel plus récent, merci ;)
Encore merci @Staple1600
 

Staple1600

XLDnaute Barbatruc
Re

@dindin
J'ai fait l'adaptation en me basant sur les infos de Microsoft
(mais pas pu testé)
Je te laisse tester
VB:
Sub test_B()
MFC_4 Range("D15:J20")
End Sub

Private Function MFC_4(Rng As Range)
Dim c
c = Array(Array("CA", 9), Array("RTT", 10), Array("CR", 7))
Rng.FormatConditions.Delete
For i = LBound(c) To UBound(c)
Rng.FormatConditions.Add Type:=1, Operator:=3, Formula1:=c(i)(0)
Rng.FormatConditions(i + 1).Interior.ThemeColor = c(i)(1)
Next
End Function
 

dindin

XLDnaute Occasionnel
Re

@dindin
J'ai fait l'adaptation en me basant sur les infos de Microsoft
(mais pas pu testé)
Je te laisse tester
VB:
Sub test_B()
MFC_4 Range("D15:J20")
End Sub

Private Function MFC_4(Rng As Range)
Dim c
c = Array(Array("CA", 9), Array("RTT", 10), Array("CR", 7))
Rng.FormatConditions.Delete
For i = LBound(c) To UBound(c)
Rng.FormatConditions.Add Type:=1, Operator:=3, Formula1:=c(i)(0)
Rng.FormatConditions(i + 1).Interior.ThemeColor = c(i)(1)
Next
End Function
je viens de le tester sur Excel 2016, c'est excellent. Merci

1681295295228.png
 

Statistiques des forums

Discussions
313 243
Messages
2 096 509
Membres
106 644
dernier inscrit
7frd5