Transférer automatiq les couleurs des cellules vers la légende d'un tableau

Bonjour,

Je voudrais transférer de manière automatique les couleurs qui se trouvent dans des cellules (avec codes couleur) vers la légende d'un graphique. L'explication se trouve dans un encadré orangé dans la feuille "Mineral abundance-Graphic" du fichier excel joint.

Merci pour votre précieuse aide.

Bonjour ,

Il faut passer par une macro en VBA .

Sub Couleur()
    Dim f1 As Worksheet, f2 As Worksheet, f3 As Worksheet
    Dim DerLig_f1 As Long, DerLig_f2 As Long, DerCol_f2 As Long
    Dim i As Long, Coul As Long, Nb_Minerais As Long

    Application.ScreenUpdating = False
    Set f1 = Sheets("Mineralogic Set-Up")
    Set f2 = Sheets("Mineralogy Pivot Table")
    Set f3 = Sheets("Mineral abundance-Graphic")
    DerLig_f1 = f1.Range("D29").End(xlDown).Row
    DerLig_f2 = f2.ListObjects("Tableau5").DataBodyRange.Rows.Count + 1
    Nb_Minerais = (DerLig_f2 - 1) / 8
    DerCol_f2 = 16 + Nb_Minerais

    'Affichage N° de la couleur
    For i = 29 To DerLig_f1
        f1.Cells(i, "F") = f1.Cells(i, "C").Interior.Color
    Next i

    'Recupération par formule des codes couleurs at application au-dessus de chaque minerai du TCD de la feuille "Mineralogy Pivot Table"
    f2.Range(f2.Cells(2, "Q"), f2.Cells(2, DerCol_f2)).FormulaR1C1 = "=INDEX('" & f1.Name & "'!R1C4:R" & DerLig_f1 & "C6,MATCH(R4C,'" & f1.Name & "'!R1C4:R" & DerLig_f1 & "C4,0),3)"

    f3.ChartObjects("Graphique 16").Activate
    For i = 1 To Nb_Minerais
        Coul = f2.Cells(2, i + 16)
        ActiveChart.SeriesCollection(i).Interior.Color = Coul
    Next i
End Sub

Le fichier

Cdlt

Bonsoir Senlis01, Arturo83,

Voir Note en rouge sur feuille Pivot ainsi que les formules dans les 4 premières colonnes.

Idem voir les formules décodage des couleurs en première feuille et la macro (ci-dessous) dans le code de la feuille Pivot

Le slicer Mineral sera automatisé si flltre changé en feuille Pivot. Idem sur feuille graphique.

Private Sub Worksheet_Calculate()
If ActiveSheet.Range("O1") = 0 Then Exit Sub
For Col = 17 To Range("O4") + 16
For Each c In Feuil7.Range("D29:D58")
If c.Text = Cells(4, Col) Then Lig = c.Row
Next c
Feuil21.ChartObjects("Graphique 16").Activate
ActiveChart.SeriesCollection(Col - 16).Interior.Color = Feuil7.Range("C" & Lig).Interior.Color
Next Col
Feuil21.Range("U66").Activate
End Sub

Edit: Correction de la note en feuille PIVOT

Bonjour,

Merci à "Arturo83" et à "X cellus" d'avoir répondu à ma demande. Je vais tester les deux solutions en intégrant le code dans un fichier contenant plus d'entrées et je vous donnerais des nouvelles.

Encore une fois merci infiniment à vous deux.

Salutations