Couleur cellule selon un critère d'une liste déroulante
RésoluJen -
Bonjour,
J'ai trouvé un code afin de définir une couleur à des cellules qui contiennent une liste déroulante. La couleur est donnée selon le critère choisit dans la liste déroulante et fait référence à une légende de couleur/critère. Tout fonctionne bien, mais je j'aimerais que la couleur s'étend dans 4 cellules en dessous. Pour finir j'aimerais que la macro s'exécute dès la sélection du critère. En souhaitant que mes explications sont claires. Voici le code ci-dessous. Merci à l'avance!
Sub ColorCellules()
Application.ScreenUpdating = False
Set F1 = ActiveSheet
With F1
Set plage = .Range("D34:M34")
End With
For Z = 39 To 46 Step 1
For Each cell In plage
cell.Select
If cell.Value = Cells(Z, 2).Value Then Selection.Interior.Color = F1.Cells(Z, 2).Interior.Color
If cell.Value = Cells(Z, 2).Value Then Selection.Font.Color = F1.Cells(Z, 2).Font.Color
Next
Next Z
Application.ScreenUpdating = True
End Sub
Windows / Chrome 122.0.0.0
3 réponses
-
yg_be Messages postés 23437 Date d'inscription Statut Contributeur Dernière intervention Ambassadeur 1 588
bonjour,
pour étendre aux 4 cellules en dessous, je ferais ainsi (pas testé, car tu n'as pas donné de fichier de test):
Option Explicit Sub ColorCellules() Dim F1 As Worksheet, Z As Integer, cell As Range, plage As Range Application.ScreenUpdating = False Set F1 = ActiveSheet Set plage = F1.Range("D34:M34") For Each cell In plage For Z = 39 To 46 Step 1 If cell.Value = Cells(Z, 2).Value Then cell.Resize(5).Interior.Color = F1.Cells(Z, 2).Interior.Color cell.Resize(5).Font.Color = F1.Cells(Z, 2).Font.Color Exit For End If Next Z Next cell Application.ScreenUpdating = True End Sub-
Pour exécuter cela automatiquement dès la sélection du critère, je mettrais ceci dans le module de la feuille:
Option Explicit Private Sub Worksheet_SelectionChange(ByVal cell As Range) Dim F1 As Worksheet, Z As Integer Application.ScreenUpdating = False Set F1 = ActiveSheet If cell.Count = 1 And Not Intersect(cell, F1.Range("D34:M34")) Is Nothing Then For Z = 39 To 46 Step 1 If cell.Value = Cells(Z, 2).Value Then Application.EnableEvents = False cell.Resize(5).Interior.Color = F1.Cells(Z, 2).Interior.Color cell.Resize(5).Font.Color = F1.Cells(Z, 2).Font.Color Application.EnableEvents = True Exit For End If Next Z End If Application.ScreenUpdating = True End Sub -
-
-
J'ai fait les changements, mais j'ai peut-être oublié quelque chose, car à la ligne If cell.Count il m'indique un bug cell est sélectionné (Erreur de compilation : Variable non définie).
Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim F1 As Worksheet, Z As Integer Application.ScreenUpdating = False Set F1 = ActiveSheet If cell.Count = 1 And Not Intersect(cell, F1.Range("D34:M34")) Is Nothing Then For Z = 39 To 46 Step 1 If cell.Value = Cells(Z, 2).Value Then Application.EnableEvents = False cell.Resize(5).Interior.Color = F1.Cells(Z, 2).Interior.Color cell.Resize(5).Font.Color = F1.Cells(Z, 2).Font.Color Application.EnableEvents = True Exit For End If Next Z End If Application.ScreenUpdating = True End Sub-
Worksheet_SelectionChange devait être remplacé par Worksheet_Change, il ne faut pas toucher au reste de la ligne, il faut simplement supprimer "Selection".
Tout fonctionne à merveille, merci!
J'aimerais ajouter deux petits trucs :
Si ce critère est sélectionné : "-" que seulement cette cellule qui soit coloré et d'étendre la couleur blanc de 5.
Un message box pour afficher qu'il n'accepte pas de cellule vide, qu'il doit obligatoirement avoir un critère de sélectionné.
J'en demande beaucoup alors merci encore!! :D
Si on n'étend pas la couleur, on y laisse alors la couleur précédente?
Toujours non testé:
Option Explicit Private Sub Worksheet_Change(ByVal cell As Range) Dim F1 As Worksheet, Z As Integer, r As Integer Set F1 = ActiveSheet If cell.Count = 1 And Not Intersect(cell, F1.Range("D34:M34")) Is Nothing Then If cell = "" Then MsgBox "oups" Else For Z = 39 To 46 Step 1 If cell.Value = Cells(Z, 2).Value Then If cell = "-" Then r = 1 Else r = 5 End If Application.EnableEvents = False cell.Resize(r).Interior.Color = F1.Cells(Z, 2).Interior.Color cell.Resize(r).Font.Color = F1.Cells(Z, 2).Font.Color Application.EnableEvents = True Exit For End If Next Z End If End If End Sub
-
-
