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
- Couleur cellule selon un critère d'une liste déroulante
- Liste déroulante excel - Guide
- Liste déroulante en cascade - Guide
- Excel cellule couleur si condition texte - Guide
- Excel compter cellule couleur sans vba - Guide
- Liste déroulante google sheet - Accueil - Guide bureautique
3 réponses
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
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
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
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 SubSuper le code pour étendre la couleur fonctionne!! Merci :)
Le code pour l'exécution automatique fonctionne, mais seulement si je reclique ensuite sur la case où se trouve le critère, il ne s'exécute pas dès la sélection. C'est quand même génial d'en être arrivé là !
Oups, je me suis trompé, Worksheet_SelectionChange doit être remplacé par Worksheet_Change.
Techniquement, il suffisait d'ajouter .Resize(5) pour étendre la couleur.
Je n'ai pas résisté et j'ai corrigé quelques maladresses dans le code.