VBA colorier des cellules sous conditions

Le
L
Bonjour,

Ma question rejoint celle de loulou et je pense bien d'autres.

Je souhaite pour une rangée de celulle A1:D500 par exemple -> si (pour
chaque cellule) la cellule est égale à "texte1" (en chaîne de
caractères) colorier en rouge, "texte2" -> telle couleur, jusqu'à sept
conditions, sinon ne rien faire et passer à la cellule suivante pour
toute ma sélection. Est-il possible de le faire automatiquement de telle
manière que dès que je remplis ma cellule il colore ma cellule qui
répond aux conditions fixées ?

D'avance merci,
Lionel
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
Hervé
Le #4944291
Bonsoir Lionel,
Un proc (à adapter bien entendu) pour colorer toute un plage :

Sub Colorer()
Dim Tbl() As String
Dim TblCouleur() As Integer
Dim Plage As Range
Dim Cel As Range
Dim Adr As String
Dim I As Integer

'rempli les tableaux pour le test
For I = 1 To 7
ReDim Preserve Tbl(1 To I)
ReDim Preserve TblCouleur(1 To I)
Tbl(I) = "Texte " & I
TblCouleur(I) = I + 2
Next I

'la plage est dans la feuille "Feuil1"
'et part de A1 à la dernière cellule
'de la colonne D
With Worksheets("Feuil1")
Set Plage = .Range(.[A1], .[D65536].End(3))
End With

'recherche la valeur de chaque élément
'du tableau
For I = 1 To UBound(Tbl)
Set Cel = Plage.Find(Tbl(I), , xlValues)
'si trouvée
If Not Cel Is Nothing Then
Adr = Cel.Address
'colore toutes les cellules correspondantes
Do
Cel.Interior.ColorIndex = TblCouleur(I)
Set Cel = Plage.FindNext(Cel)
Loop While Cel.Address <> Adr
End If
Next I

Set Cel = Nothing
Set Plage = Nothing
Erase Tbl
End Sub

Si tu veux que la cellule active soit colorée après un changement de valeur,
à mettre dans le module de ta feuille :

Private Sub Worksheet_Change(ByVal Target As Range)

Select Case Target
Case "texte 1"
Target.Interior.ColorIndex = 3
Case "texte 2"
Target.Interior.ColorIndex = 4
Case "texte 3"
Target.Interior.ColorIndex = 5
Case "texte 4"
Target.Interior.ColorIndex = 6
Case "texte 5"
Target.Interior.ColorIndex = 7
Case "texte 6"
Target.Interior.ColorIndex = 8
Case "texte 7"
Target.Interior.ColorIndex = 9
Case Else
Target.Interior.ColorIndex = 0
End Select

End Sub

Si toutes les feuilles du classeur sont concernées, utilise les mêmes ligne
de code dans l'évennement "Private Sub Workbook_SheetChange".

Hervé.

"L"
Bonjour,

Ma question rejoint celle de loulou et je pense bien d'autres.

Je souhaite pour une rangée de celulle A1:D500 par exemple -> si (pour
chaque cellule) la cellule est égale à "texte1" (en chaîne de
caractères) colorier en rouge, "texte2" -> telle couleur, jusqu'à sept
conditions, sinon ne rien faire et passer à la cellule suivante pour
toute ma sélection. Est-il possible de le faire automatiquement de telle
manière que dès que je remplis ma cellule il colore ma cellule qui
répond aux conditions fixées ?

D'avance merci,
Lionel


L
Le #4572701
Bonsoir Lionel,
Un proc (à adapter bien entendu) pour colorer toute un plage :
Salut Hervé et merci pour ta réponse que je n'arrive pas à mettre en

place. Il n'y a pas d'erreur mais il ne se passe rien. Peut-être ai-je
mal renseigné les champs ?
Voici un exemple de fichier excel
http://lola2k.free.fr/pub/color_value/chroniq_act.xls
dont j'aimerais colorer les colonnes E à I selon qu'elles correspondent
à certains critères (chaîne de caractères).

Sub Colorer()
Dim Tbl() As String
Dim TblCouleur() As Integer
Dim Plage As Range
Dim Cel As Range
Dim Adr As String
Dim I As Integer

'rempli les tableaux pour le test
For I = 1 To 7
ReDim Preserve Tbl(1 To I)
ReDim Preserve TblCouleur(1 To I)
Tbl(I) = "Texte " & I
faut-il ici modifier quelque chose ?

TblCouleur(I) = I + 2
Next I

'la plage est dans la feuille "Feuil1"
'et part de A1 à la dernière cellule
'de la colonne D
With Worksheets("Feuil1")
Set Plage = .Range(.[A1], .[D65536].End(3))
j'ai modifié le Range

End With

'recherche la valeur de chaque élément
'du tableau
For I = 1 To UBound(Tbl)
Set Cel = Plage.Find(Tbl(I), , xlValues)
'si trouvée
If Not Cel Is Nothing Then
Adr = Cel.Address
'colore toutes les cellules correspondantes
Do
Cel.Interior.ColorIndex = TblCouleur(I)
Set Cel = Plage.FindNext(Cel)
Loop While Cel.Address <> Adr
End If
Next I

Set Cel = Nothing
Set Plage = Nothing
Erase Tbl
End Sub
je ne comprends pas entrer les critères

J'ai bien vu la suite et entré mes critères : remmplacé "texte 1" par
mon 1er critère, etc.
Mais rien de plus ...
Lionel

Si tu veux que la cellule active soit colorée après un changement de valeur,
à mettre dans le module de ta feuille :

Private Sub Worksheet_Change(ByVal Target As Range)

Select Case Target
Case "texte 1"
Target.Interior.ColorIndex = 3
Case "texte 2"
Target.Interior.ColorIndex = 4
Case "texte 3"
Target.Interior.ColorIndex = 5
Case "texte 4"
Target.Interior.ColorIndex = 6
Case "texte 5"
Target.Interior.ColorIndex = 7
Case "texte 6"
Target.Interior.ColorIndex = 8
Case "texte 7"
Target.Interior.ColorIndex = 9
Case Else
Target.Interior.ColorIndex = 0
End Select

End Sub

Si toutes les feuilles du classeur sont concernées, utilise les mêmes ligne
de code dans l'évennement "Private Sub Workbook_SheetChange".

Hervé.

"L"
Bonjour,

Ma question rejoint celle de loulou et je pense bien d'autres.

Je souhaite pour une rangée de celulle A1:D500 par exemple -> si (pour
chaque cellule) la cellule est égale à "texte1" (en chaîne de
caractères) colorier en rouge, "texte2" -> telle couleur, jusqu'à sept
conditions, sinon ne rien faire et passer à la cellule suivante pour
toute ma sélection. Est-il possible de le faire automatiquement de telle
manière que dès que je remplis ma cellule il colore ma cellule qui
répond aux conditions fixées ?

D'avance merci,
Lionel






L
Le #4572661
me réponse précédente un poil rapide. Cela foncitonne bien pour "texte
1", "texte 2", etc.
Je me suis ma expliqué.

Mes conditions à vérifier sont :"zoom", "rotate", "cut", filter",
"translation" et non littéralement "texte 1", "texte 2", etc.

Merci,
Lionel

Bonsoir Lionel,
Un proc (à adapter bien entendu) pour colorer toute un plage :

Sub Colorer()
Dim Tbl() As String
Dim TblCouleur() As Integer
Dim Plage As Range
Dim Cel As Range
Dim Adr As String
Dim I As Integer

'rempli les tableaux pour le test
For I = 1 To 7
ReDim Preserve Tbl(1 To I)
ReDim Preserve TblCouleur(1 To I)
Tbl(I) = "Texte " & I
TblCouleur(I) = I + 2
Next I

'la plage est dans la feuille "Feuil1"
'et part de A1 à la dernière cellule
'de la colonne D
With Worksheets("Feuil1")
Set Plage = .Range(.[A1], .[D65536].End(3))
End With

'recherche la valeur de chaque élément
'du tableau
For I = 1 To UBound(Tbl)
Set Cel = Plage.Find(Tbl(I), , xlValues)
'si trouvée
If Not Cel Is Nothing Then
Adr = Cel.Address
'colore toutes les cellules correspondantes
Do
Cel.Interior.ColorIndex = TblCouleur(I)
Set Cel = Plage.FindNext(Cel)
Loop While Cel.Address <> Adr
End If
Next I

Set Cel = Nothing
Set Plage = Nothing
Erase Tbl
End Sub

Si tu veux que la cellule active soit colorée après un changement de valeur,
à mettre dans le module de ta feuille :

Private Sub Worksheet_Change(ByVal Target As Range)

Select Case Target
Case "texte 1"
Target.Interior.ColorIndex = 3
Case "texte 2"
Target.Interior.ColorIndex = 4
Case "texte 3"
Target.Interior.ColorIndex = 5
Case "texte 4"
Target.Interior.ColorIndex = 6
Case "texte 5"
Target.Interior.ColorIndex = 7
Case "texte 6"
Target.Interior.ColorIndex = 8
Case "texte 7"
Target.Interior.ColorIndex = 9
Case Else
Target.Interior.ColorIndex = 0
End Select

End Sub

Si toutes les feuilles du classeur sont concernées, utilise les mêmes ligne
de code dans l'évennement "Private Sub Workbook_SheetChange".

Hervé.

"L"
Bonjour,

Ma question rejoint celle de loulou et je pense bien d'autres.

Je souhaite pour une rangée de celulle A1:D500 par exemple -> si (pour
chaque cellule) la cellule est égale à "texte1" (en chaîne de
caractères) colorier en rouge, "texte2" -> telle couleur, jusqu'à sept
conditions, sinon ne rien faire et passer à la cellule suivante pour
toute ma sélection. Est-il possible de le faire automatiquement de telle
manière que dès que je remplis ma cellule il colore ma cellule qui
répond aux conditions fixées ?

D'avance merci,
Lionel






Hervé
Le #4570671
Bonsoir Lionel,
Une piste peut être. Dans une autre feuille (ici Feuil2) inscrit tous les
mots en colonne "A" dont tu veux colorer la valeur et cache la feuille
(Format-Feuille-Masquer, si tu veux bien sûr..).
A mettre dans le module du classeur si toutes les feuilles sont concernées,
sinon récupérer que les lignes de code pour les mettre dans la proc
Worksheet_SelectionChange de la feuille concernée.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Plage As Range
Dim Cel As Range

'évite "Feuil2" pour colorer les cellules
If Sh.Name = "Feuil2" Then Exit Sub

'défini la plage des mots se trouvant
'dans la colonne "A"
With Worksheets("Feuil2")
Set Plage = .Range(.[A1], .[A63536].End(3))
End With
'recherche le mot dans la liste
Set Cel = Plage.Find(Target, , xlValues)
'si il existe, colore la cellule
'sinon supprime la couleur
'attention, 56 couleurs max
If Not Cel Is Nothing Then
Target.Interior.ColorIndex = Cel.Row + 3
Else
Target.Interior.ColorIndex = 0
End If

Set Cel = Nothing
Set Plage = Nothing

End Sub

Hervé.


"L"
me réponse précédente un poil rapide. Cela foncitonne bien pour "texte
1", "texte 2", etc.
Je me suis ma expliqué.

Mes conditions à vérifier sont :"zoom", "rotate", "cut", filter",
"translation" et non littéralement "texte 1", "texte 2", etc.

Merci,
Lionel

Bonsoir Lionel,
Un proc (à adapter bien entendu) pour colorer toute un plage :

Sub Colorer()
Dim Tbl() As String
Dim TblCouleur() As Integer
Dim Plage As Range
Dim Cel As Range
Dim Adr As String
Dim I As Integer

'rempli les tableaux pour le test
For I = 1 To 7
ReDim Preserve Tbl(1 To I)
ReDim Preserve TblCouleur(1 To I)
Tbl(I) = "Texte " & I
TblCouleur(I) = I + 2
Next I

'la plage est dans la feuille "Feuil1"
'et part de A1 à la dernière cellule
'de la colonne D
With Worksheets("Feuil1")
Set Plage = .Range(.[A1], .[D65536].End(3))
End With

'recherche la valeur de chaque élément
'du tableau
For I = 1 To UBound(Tbl)
Set Cel = Plage.Find(Tbl(I), , xlValues)
'si trouvée
If Not Cel Is Nothing Then
Adr = Cel.Address
'colore toutes les cellules correspondantes
Do
Cel.Interior.ColorIndex = TblCouleur(I)
Set Cel = Plage.FindNext(Cel)
Loop While Cel.Address <> Adr
End If
Next I

Set Cel = Nothing
Set Plage = Nothing
Erase Tbl
End Sub

Si tu veux que la cellule active soit colorée après un changement de
valeur,


à mettre dans le module de ta feuille :

Private Sub Worksheet_Change(ByVal Target As Range)

Select Case Target
Case "texte 1"
Target.Interior.ColorIndex = 3
Case "texte 2"
Target.Interior.ColorIndex = 4
Case "texte 3"
Target.Interior.ColorIndex = 5
Case "texte 4"
Target.Interior.ColorIndex = 6
Case "texte 5"
Target.Interior.ColorIndex = 7
Case "texte 6"
Target.Interior.ColorIndex = 8
Case "texte 7"
Target.Interior.ColorIndex = 9
Case Else
Target.Interior.ColorIndex = 0
End Select

End Sub

Si toutes les feuilles du classeur sont concernées, utilise les mêmes
ligne


de code dans l'évennement "Private Sub Workbook_SheetChange".

Hervé.

"L"
Bonjour,

Ma question rejoint celle de loulou et je pense bien d'autres.

Je souhaite pour une rangée de celulle A1:D500 par exemple -> si (pour
chaque cellule) la cellule est égale à "texte1" (en chaîne de
caractères) colorier en rouge, "texte2" -> telle couleur, jusqu'à sept
conditions, sinon ne rien faire et passer à la cellule suivante pour
toute ma sélection. Est-il possible de le faire automatiquement de
telle



manière que dès que je remplis ma cellule il colore ma cellule qui
répond aux conditions fixées ?

D'avance merci,
Lionel








Publicité
Poster une réponse
Anonyme