Colorer graph en fonction des abscisses

[aubrespinj]

Bonjour,

je cherche à colorer les barres d'un histogramme en fonction des données de l'axe des abscisses (non pas des étiquettes situées sur les barres)...

Concrètement, le graph présente les résultats de plusieurs entreprises et est modifié chaque jour...ainsi je veux que la barre qui représente le CA de l'entreprise XX soit toujours bleue et celle de l'entreprise Y toujours rouge...même si d'un jour à l'autre la barre n'est plus au même endroit (CA différent) !

J'ai trouvé le code suivant :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub colorgraph()
Dim i As Integer
 
For i = 1 To Sheets(1).ChartObjects("Chart 20").Chart.SeriesCollection(1).Points.Count
Sheets(1).ChartObjects("Chart 20").Chart.SeriesCollection(1).Points(i).ApplyDataLabels Type:= _
xlDataLabelsShowLabel, AutoText:=False
If Sheets(1).ChartObjects("Chart 20").Chart.SeriesCollection(1).Points(i).DataLabel.Text = "XXX " Then
Sheets(1).ChartObjects("Chart 20").Chart.SeriesCollection(1).Points(i).Interior.Color = vbRed
End If
If Sheets(1).ChartObjects("Chart 20").Chart.SeriesCollection(1).Points(i).DataLabel.Text = "YYY" Then
Sheets(1).ChartObjects("Chart 20").Chart.SeriesCollection(1).Points(i).Interior.ColorIndex = 43
End If
 
Next
 
End Sub

Le problème c'est que ce code me rajoute le nom des différentes entreprises (qui sont déjà en abscisses) sur les barres !
Je cherche donc à produire un code qui puisse directement regarder le texte de la barre des abscisses et colorer les barres en fonction !

Merci pour votre aide !

[mercatog]

Bonjour
Proposition à adapter

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub ColorGraph()
Dim Sc As Object
Dim i As Integer
Dim Klr As Byte
Dim Tb
 
Set Sc = Sheets(1).ChartObjects("Graphique 1").Chart.SeriesCollection(1)    'ADAPTER LE NOM DU GRAPHIQUE
Tb = Sc.XValues
With Sc
    For i = 1 To .Points.Count
        Select Case Tb(i)
            Case "XXX": Klr = 4
            Case "YYY": Klr = 14
            Case "ZZZ": Klr = 24
            Case "VVV": Klr = 34
            Case "WWW": Klr = 44
            Case Else: Klr = 1
        End Select
        .Points(i).Interior.ColorIndex = Klr
    Next
End With
Set Sc = Nothing
End Sub