XL 2010 colorer cellules VBA

[eastwick]

Bonjour à toutes et tous,

Je reviens vers vous avec mon souci, mais ma requête est différente et plus détaillée.
Tout est expliqué dans le fichier.

Merci

 

[Lolote83]

Bonjour,
Juste en passant,
Pourquoi du VBA ? Est-ce obligatoire alors qu'une simple MFC (Mise en forme conditionnelle) devrait le faire ?
Pas le temps pour la réponse immédiate, mais plus tard si aucune réponse d'ici demain
@+ Lolote83

 

[Robert]

Bonjour Eastwick, bonjour le forum,

Sélectionne la plage ou tu veux que ça agisse et lance le code ci-dessous :

Sub Macro1()
Dim PL As Range 'déclare la variable PL (PLage)
Dim R As Range 'déclare la variable R (Recherche)
Dim PA As String 'déclare la variable PA (Première Adresse)

'couleur grise pour les "r"
Set PL = Selection 'définit la plage PL (la sélection)
Set R = PL.Find("r", , xlValues, xlWhole) 'définit la recherche R (recherche "r" dans la sélection)
If Not R Is Nothing Then 'condition : s'il existe au moins une occurrence trouvée
  PA = R.Address 'définit l'adresse PA de la première occurrence
  Do 'exécute
  With R.Offset(1, 0).Resize(8, 1).Interior 'prend en compte l'intérieur de la cellule en dessous de l'occurrence trouvée redimensionnée à 8 lignes
  .Pattern = xlSolid 'carastériqtique couleurs grise
  .PatternColorIndex = xlAutomatic 'carastériqtique couleurs grise
  .ThemeColor = xlThemeColorDark1 'carastériqtique couleurs grise
  .TintAndShade = -0.249977111117893 'carastériqtique couleurs grise
  .PatternTintAndShade = 0 'carastériqtique couleurs grise
  End With 'fin de la prise en compte...
  Set R = PL.FindNext(R) 'recherche l'occurrence suivante
  Loop While Not R Is Nothing And R.Address <> PA 'boucle tant qu'il y a des occurrence ailleurs qu'en PA
End If 'fin de la condition
Set R = Nothing: PA = "" 'vide la variable R, vide la variable PA

'couleur bleue pour les "f"
Set R = PL.Find("f", , xlValues, xlWhole)
If Not R Is Nothing Then
  PA = R.Address
  Do
  With R.Offset(1, 0).Resize(8, 1).Interior
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  .Color = 12611584
  .TintAndShade = 0
  .PatternTintAndShade = 0
  End With
  Set R = PL.FindNext(R)
  Loop While Not R Is Nothing And R.Address <> PA
End If
Set R = Nothing: PA = ""

'couleur jaune pour les "CA"
Set R = PL.Find("CA", , xlValues, xlWhole)
If Not R Is Nothing Then
  PA = R.Address
  Do
  With R.Interior
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  .Color = 65535
  .TintAndShade = 0
  .PatternTintAndShade = 0
  End With
  Set R = PL.FindNext(R)
  Loop While Not R Is Nothing And R.Address <> PA
End If
Set R = Nothing: PA = ""

'couleur violette pour les "RTT"
Set R = PL.Find("RTT", , xlValues, xlWhole)
If Not R Is Nothing Then
  PA = R.Address
  Do
  With R.Interior
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  .ThemeColor = xlThemeColorAccent4
  .TintAndShade = 0.399975585192419
  .PatternTintAndShade = 0
  End With
  Set R = PL.FindNext(R)
  Loop While Not R Is Nothing And R.Address <> PA
End If
Set R = Nothing: PA = ""

'couleur ??? pour les "CET"
Set R = PL.Find("RTT", , xlValues, xlWhole)
If Not R Is Nothing Then
  PA = R.Address
  Do
  With R.Interior
  .Pattern = xlSolid
  .PatternColorIndex = xlAutomatic
  .ThemeColor = xlThemeColorAccent6
  .TintAndShade = 0.399975585192419
  .PatternTintAndShade = 0
  End With
  Set R = PL.FindNext(R)
  Loop While Not R Is Nothing And R.Address <> PA
End If
Set R = Nothing: PA = ""
End Sub

[Édition]
Bojour Lolote, nos posts se sont croisés... Je crois que c'est parce sa plage est aléatoire...

 

[eastwick]

Bonjour, il faut lancer une macro ou c'est automatique ?

 

[eastwick]

Bonjour,
Juste en passant,
Pourquoi du VBA ? Est-ce obligatoire alors qu'une simple MFC (Mise en forme conditionnelle) devrait le faire ?
Pas le temps pour la réponse immédiate, mais plus tard si aucune réponse d'ici demain
@+ Lolote83

Parce que les utilisateurs flinguent les formules avec des copier coller et couper coller à outrance...

 

[eastwick]

Si j'étais le seul utilisateur, pas de souci. Mais ce n'est pas le cas. Je préfèrerais donc un code VBA actif immédiatement sans lancer de macro.

 

[Robert]

Re,

Si tu relis j'ai bien écrit lance le code...

 

[eastwick]

Re,

Si tu relis j'ai bien écrit lance le code...

Et comment lance t'on le code ?

 

[Robert]

Re,

On pourrait la lancer automatiquement si, par exemple, la sélection contient plus d'un seule cellule (ou plus de x cellules) avec l'événement Selection_Change qui est automatique. Mais tu n'as rien précisé de tout cela et on n'est pas devins... Je suis en pause...

 

[eastwick]

ok. Donc si vous avez le temps, j'aimerais que la procédure soit automatique et réversible. Les infos sont saisies : colorations des cellules concernées, les infos sont supprimées : les cellules redeviennent vides. Désolé pour le manque de précision mais vous êtes ma seule solution si je veux conserver mon fichier de manière durable. Un grand merci.

 

[Robert]

Re,

Finalement c'est bien plus simple et ça agit au changement dans une cellule. Code à mettre dans le composant de l'onglet concerné. Feuil1(Feuil1) par exemple :

Private Sub Worksheet_Change(ByVal Target As Range) 'au changement dans l'onglet
If Selection.Cells.Count > 1 Then Exit Sub 'si plus d'une seule cellule est sélectionnée, sort de la procédure
Select Case Target.Value 'agit en fonction de la cellule moditiée
  
  Case "r" 'couleur grise pour les "r"
  With Target.Offset(1, 0).Resize(8, 1).Interior 'prend en compte l'intérieur des 8 cellules en-dessous de la cellule modifiées
  .ThemeColor = xlThemeColorDark1 'carastériqtique couleurs grise
  .TintAndShade = -0.249977111117893 'carastériqtique couleurs grise
  End With 'fin de la prise en compte...
  
  Case "f" 'couleur bleue pour les "f"
  With Target.Offset(1, 0).Resize(8, 1).Interior 'prend en compte l'intérieur des 8 cellules en-dessous de la cellule modifiées
  .Color = 12611584
  End With 'fin de la prise en compte...
  
  Case "CA" 'couleur jaune pour les "CA"
  With Target.Interior 'prend en compte la cellule modifiée
  .Color = 65535
  End With 'fin de la prise en compte...
  
  Case "RTT" 'couleur violette pour les "RTT"
  With Target.Interior 'prend en compte la cellule modifiée
  .ThemeColor = xlThemeColorAccent4
  .TintAndShade = 0.399975585192419
  End With 'fin de la prise en compte...
  
  Case "CET" 'couleur ? pour les "CTE"
  With Target.Interior 'prend en compte la cellule modifiée
  .ThemeColor = xlThemeColorAccent6
  .TintAndShade = 0.399975585192419
  End With 'fin de la prise en compte...
  
  Case "" 'si la cellule est effacée
  If Target.Interior.ColorIndex <> xlNone Then Target.Interior.ColorIndex = xlNone 'si la cellule est colorée, supprime la couleur
  'condition : si la cellule en dessous est bleu ou grise
  If Target.Offset(1, 0).Interior.ThemeColor = xlThemeColorDark1 Or Target.Offset(1, 0).Interior.Color = 12611584 Then 'condition : si la cellule en dessous est bleu ou grise
  Target.Offset(1, 0).Resize(8, 1).Interior.ColorIndex = xlNone 'enlève la couleur aux 8 cellules en dessous
  End If 'fin de la condition
End Select 'fin de l'action en fonction de la valeur de la cellule modifiée
End Sub

 

[eastwick]

Nickel chrome. Un immense merci. Désolé d'avoir laissé cette impression d'immédiateté, ce qui était loin d'être le cas...

 

[eastwick]

Bonjour à toutes et tous, Robert, le forum...
Pour finaliser le fichier suivant, j'aimerais que les couleurs bleue et grise se mettent sous "r" et "f" ou s'effacent sous "vide" de façon automatique selon le choix de l'année, cliquer sur un exercice et vous comprendrez. Ensuite que les cellules comportant CA, RTT ou CET puissent avoir leur contenu supprimé en bloc et se décolorer en conséquence. Ici, il faut les supprimer une par une pour que la décoloration prenne effet.
D'avance merci...