VBA - Changer les couleurs de series sur graphs

[livinne]

Bonjour a tous,

Tout d'abord je vous prie de bien vouloir m'excuser pour l'absence d'accents, je travaille sur un clavier QWERTY.
Je travaille sur un projet pour lequel je tente de faire concorder les couleurs des differents graphiques de ma feuille de calcul via VBA, sans succes.

J'aurai besoin que ma macro mette mes graphiques en forme afin que la zone 1 soit systematiquement representee en rouge dans tous mes graphs, que la zone 2 soit en bleu... Selon les couleurs definies dans une feuille separee.

Je vais tenter de vous mettre un exemple en PJ.

Pourriez-vous m'aider?

Merci d'avance!
Regarde la pièce jointe Trial.xlsx

 

[mapomme]

Re : VBA - Changer les couleurs de series sur graphs

Bonsoir livinne et bienvenue sur XLD 🙂,

Un essai dans le fichier joint.

Le tableau des correspondances zones <-> couleurs a été lègèrement modifié. La couleur appliquée à chaque zone est la couleur de fond de la cellule où se trouve le nom de la zone.

Le code est dans module1:

Sub macroCOULBarre()
Dim i&, j&, k&, Texte$, xrg As Range, sh As Worksheet


  Set sh = Sheets("Codescouleurindex")
  ActiveSheet.ChartObjects("Chart 3").Activate
  With ActiveChart
    For j = 1 To .SeriesCollection.Count
      With .SeriesCollection(j)
        Texte = .Name
        For k = 2 To 9999
          If Len(sh.Cells(k, "a")) = 0 Then Exit For
          If LCase(Texte) Like "*" & LCase(sh.Cells(k, "a")) & "*" Then
            .Format.Fill.ForeColor.RGB = sh.Cells(k, "a").Interior.Color
            Exit For
          End If
        Next k
      End With
    Next j
  End With
  Range("j25").Activate
End Sub


Sub macroCOULSecteur()
Dim i&, j&, k&, Texte$, xrg As Range, sh As Worksheet
  
  Set sh = Sheets("Codescouleurindex")
  ActiveSheet.ChartObjects("Chart 1").Activate
  With ActiveChart.SeriesCollection(1)
    .ApplyDataLabels
    .DataLabels.ShowSeriesName = True
    .DataLabels.ShowCategoryName = True
    For i = 1 To .Points.Count
      Texte = .Points(i).DataLabel.Text
      For k = 2 To 9999
        If Len(sh.Cells(k, "a")) = 0 Then Exit For
        If LCase(Texte) Like "*" & LCase(sh.Cells(k, "a")) & "*" Then
          .Points(i).Format.Fill.ForeColor.RGB = sh.Cells(k, "a").Interior.Color
          Exit For
        End If
      Next k
    Next i
    .DataLabels.ShowSeriesName = False
    .DataLabels.ShowCategoryName = False
    .DataLabels.ShowValue = False
  End With
  Range("a16").Activate
End Sub