Attribuer une couleur de remplissage à partir d'une couleur

Boujour,

J'aimerais attribuer une couleur de remplissage à une cellule en fonction de la couleur de remplissage d'une autre cellule. Je n'arrive pas à "récupérer la couleur" pour la réutiliser ensuite.

Je m'excuse si ce sujet à déjà été traité mais je ne l'ai pas trouvé.

Je vous joint mon fichier. Plus précisément j'aimerais que les couleurs qui sont attribuées aux différentes personnes de l'onglet "Chiffres" se mettent automatiquement lorsque l'on inscrit ces personnes sur le planning du premier onglet.

Voilà, j'espère avoir été suffisamment clair et merci de vos réponse.

Bonsoir,

Voilà une procédure à mettre dans le module de la feuille, qui fonctionnera quand tu auras mis des couleurs en colonne D sur Chiffres en regard des noms. Pour l'instant il n'y en a pas. La MFC (à plus forte raison en échelle multicolore) n'est pas une couleur identifiable en vue de la reproduire.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, cn As Range, clr&, nom$
    For Each c In Target.Cells
        If c.Value <> nom Then
            nom = c.Value
            Set cn = Worksheets("Chiffres").Columns("C").Find(nom, , , xlWhole)
            If Not cn Is Nothing Then
                clr = cn.Offset(0, 1).Interior.Color
                c.Interior.Color = clr
            Else
                nom = ""
            End If
        Else
            c.Interior.Color = clr
        End If
    Next c
End Sub

Si tu pouvais me dire pourquoi les cellules de ton planning deviennent noires lorsqu'on efface le contenu, ça m'intéresserait.

Cordialement

Ferrand

Bonjour,

Merci pour ta réponse. Je suis passée par une MFC car la liste des participants change tout les temps. Je veux que mon fichier soit réutilisable donc le nombre de personne n'est pas défini. La MFC permet de me donner autant de couleur qu'il y a de participant, je n'ai pas trouvée d'autre solution.

Pour le planning, mes cellules ne devienne pas noires lorsque l'on efface le contenu. Peut être est-ce un beug dû à la compression du fichier ?

Cordialement

En fait, si je viens de mettre ton code et j'ai des cases noires maintenant, du coup peut être que celà viens du code ?

Kyos a écrit :

En fait, si je viens de mettre ton code et j'ai des cases noires maintenant, du coup peut être que celà viens du code ?

Pas que je sache, cela est survenu avant que j'écrive le code !

J'ai modifié le code de la manière suivante et je n'ai plus le problème

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim c As Range, cn As Range, clr&, nom$
    For Each c In Target.Cells
            nom = c.Value
            Set cn = Worksheets("Chiffres").Columns("C").Find(nom, , , xlWhole)
            If Not nom Like "" Then
                clr = cn.Offset(0, 1).Interior.Color
                c.Interior.Color = clr
            Else
                nom = ""
                c.Interior.Color = RGB(242, 236, 221)
            End If
    Next c
End Sub

Evidemment, parce que tu remets la couleur de fond !

Note que tu pouvais le faire sans supprimer l'économie de repasser par Find lorsqu'on étendait un nom par "recopie" par exemple. Le For Each... n'avait d'ailleurs d'utilité que pour ce cas : plusieurs cellules saisies simultanément avec le même nom.

D'accord, merci beaucoup en tout cas

Par rapport au dégradé de couleur, y a t'il moyen d'en créer un sans la MFC en fonction du nombre de personnes dans la liste ?

Quelque chose comme ça :

Sub Dégrader()
    Dim n%, i%, c As Range
    n = Selection.Cells.Count
    For Each c In Selection
        c.Interior.Color = RGB(Int(240 * (1 - i / n) + 12), _
         Int(240 * (1 - Abs(n / 2 - i) / (n / 2)) + 12), _
         Int(240 * (1 - (n - i) / n) + 12))
         i = i + 1
    Next c
End Sub

Fonctionne sur une sélection de cellules. On sélectionne et on lance la macro.

Ici, on va de rouge vers bleu : on diminue le rouge en augmentant le bleu, le vert augmentant puis diminuant domine à mi-parcours.

Cela manque peut-être un peu de jaune orangé. En diminuant le rouge au démarrage (enlever +12) on part d'un ton plutôt orangé (mais plus de rouge net).

On peut essayer de nuancer diversement : si on obtient une erreur, c'est qu'on dépasse quelque part les valeurs autorisées (0 à 255).

Pas plus de jaune mais une meilleure distinction dans les verts (qui avaient tendance à fusionner dans la partie centrale pour la précédente).

Sub Dégrader()
    Dim n%, i%, c As Range
    n = Selection.Cells.Count
    For Each c In Selection
        c.Interior.Color = RGB(Int(240 * (1 - i / n) + 12), _
         Int(240 * (1 - Abs(n / 2 - i) / (n / 2)) + 12), _
         Int(240 * (1 - (n * 2 - i) / (n * 2)) + 12))
         i = i + 1
    Next c
End Sub

Merci beaucoup