XL 2021 Appliquer une couleur

[bobafric]

Bonjour à tous, dans la feuille il faudrait qu'en appliquant une couleur à une des cellules de la colonne K les cellules de la même valeur dans (A1:H30) soient coloriées. Merci à tous pour votre aide et pardonnez moi de vous faire bosser un dimanche

 

[Staple1600]

Bonjour le fil

@bobafric
En attendant mieux, une solution par macro

Sub Colorier()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Selection
ligne = Application.Match(c, Range("K1:K16"), 0)
c.Interior.ColorIndex = Cells(ligne, "K").Interior.ColorIndex
Next
End Sub

Ci-dessous résultat obtenu

 

[sylvanu]

Bonjour Bobafric, Staple,
Un essai en PJ avec :

Sub Coloriage()
    Dim L%, C%, T, Couleur, Valeur
    T = [A1].CurrentRegion
    [A1].CurrentRegion.Interior.Color = xlNone
    For L = 1 To 16
        If Cells(L, "K").Interior.Color <> xlNone And Cells(L, "K").Interior.Color <> vbWhite Then
            Valeur = Cells(L, "K"): Couleur = Cells(L, "K").Interior.Color: Exit For
        End If
    Next L
    For L = 1 To UBound(T)
        For C = 1 To UBound(T, 2)
            If T(L, C) = Valeur Then Cells(L, C).Interior.Color = Couleur
        Next C
    Next L
End Sub

 

[Staple1600]

Bonjour sylvanu

@bobafric
En relisant le premier message, j'ai changé mon fusil d'épaule

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim c As Range
If Not Intersect(Range("K1:K16"), Target) Is Nothing Then
Application.ScreenUpdating = False
For Each c In Range("A1:H30")
If c.Value = Target.Value Then
c.Interior.ColorIndex = Target.Interior.ColorIndex
End If
Next
End If
End Sub

Code VBA à mettre dans le code de la feuille (pas dans un module standard)
Ensuite, on change une couleur en K1:K16 puis on double-clique sur la cellule dont on vient de changer la couleur.

 

[Staple1600]

Re

@bobafric
Je ne sais pas pourquoi mais grâce au code de @sylvanu, je me suis apercu que Interior.Color est plus fidèle pour restituer la couleur
J'ai donc adapté mon code précédent en conséquence

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim c As Range
If Not Intersect(Range("K1:K16"), Target) Is Nothing Then
Range("A1:H30").ClearFormats
Application.ScreenUpdating = False
For Each c In Range("A1:H30")
If c.Value = Target.Value Then
c.Interior.Color = Target.Interior.Color
End If
Next
End If
End Sub

 

[bobafric]

Re

@bobafric
Je ne sais pas pourquoi mais grâce au code de @sylvanu, je me suis apercu que Interior.Color est plus fidèle pour restituer la couleur
J'ai donc adapté mon code précédent en conséquence

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim c As Range
If Not Intersect(Range("K1:K16"), Target) Is Nothing Then
Range("A1:H30").ClearFormats
Application.ScreenUpdating = False
For Each c In Range("A1:H30")
If c.Value = Target.Value Then
c.Interior.Color = Target.Interior.Color
End If
Next
End If
End Sub

Salut Sylvanu salut barbatruc, merci pour vos efforts. Les solutions fonctionnent bien entendu, mais il faudrait que l'on puisse faire la manoeuvre pour plusieurs couleurs. je m'explique je dois colorier plusieurs cellules d'une couleur différente. Vos solutions fonctionnent avec une seule couleur, on ne peut pas colorier une autre cellule.

 

[Staple1600]

Re

@bobafric

mais il faudrait que l'on puisse faire la manoeuvre pour plusieurs couleurs. je m'explique je dois colorier plusieurs cellules d'une couleur différente

Ce n'est pas ce que faisait la macro proposée dans le message#2 ?
Voir copie d'écran

 

[Staple1600]

Re

@bobafric
Donc en modifiant ma 1erè proposition (en tenant compte des échanges précédents dans le fil)

Sub ColorierBIS()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Range("A1:H30")
ligne = Application.Match(c, Range("K1:K16"), 0)
c.Interior.Color = Cells(ligne, "K").Interior.Color
Next
End Sub

J'obtiens

 

[bobafric]

Re

@bobafric
Donc en modifiant ma 1erè proposition (en tenant compte des échanges précédents dans le fil)

Sub ColorierBIS()
Dim c As Range
Application.ScreenUpdating = False
For Each c In Range("A1:H30")
ligne = Application.Match(c, Range("K1:K16"), 0)
c.Interior.Color = Cells(ligne, "K").Interior.Color
Next
End Sub

J'obtiens
Regarde la pièce jointe 1212685

Désolé Barbatruc ça ne fonctionne pas, je joins le fichier avec ta première proposition sur la feuille 1 et la deuxième sur la feuille 2. Peut être que je l'ai mal appliqué

 

[bobafric]

Merci Staple ça marche bon dimanche à tous

 

[Staple1600]

Re

@bobafric
[Juste pour info]
En toute logique, on marque comme solution le message du contributeur qui a posté la solution, et non pas son propre message.
Donc si c'est la solution de@sylvanu que tu as retenu, c'est le message#3 qui devrait avoir la coche verte
Si c'est ma dernière proposition, c'est le message#8 qui devrait avoir la coche verte.