Microsoft 365 Associer une variable à une couleur dans des graphiques excel à plusieurs feuilles

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
MLGARIN

MLGARIN

XLDnaute Nouveau
Bonjour, je souhaite analyser des données de 32 produits qui ont été évalués sur différents critères. Je souhaiterai que pour tous les graphiques que je vais faire (sur différentes feuilles du fichier), un produit soit associé à une couleur. Et cela quelques soit la position du produit dans la colonne (notamment changement de place lorsque j'ai besoin de faire des tri par ordre croissant de la valeur du critère). Est-ce que qq aurait une solution ? Pour le moment je recolorie toutes les barres de mes histogrammes une par une ... Galère
 
Trier par date Trier par votes
Bonjour,

Je te propose cette macro

VB: 
Sub ColorierBarresHistogramme()
    Const FeuilleParam  As String = "Catégories"
    Const GreyOtherBar  As Boolean = False
    
    Dim objChart        As chart
    Dim objSeries       As Series
    Dim i               As Long, j As Long
    Dim wsCat           As Worksheet
    Dim objCatDict      As Object
    Dim lgLastRow       As Long
    Dim strCatName      As String
    Dim boByCategorie   As Boolean
    
    On Error GoTo erreur
    If TypeName(Selection) <> "ChartArea" And TypeName(Selection) <> "PlotArea" Then
        MsgBox "Veuillez sélectionner le graphique (histogramme) à modifier.", vbExclamation
        Exit Sub
    End If

    Set objChart = ActiveChart ' Récupère le graphique sélectionné
    Set wsCat = ActiveWorkbook.Sheets(FeuilleParam)
    Set objCatDict = CreateObject("Scripting.Dictionary") ' Création du dictionnaire

    lgLastRow = wsCat.Cells(70000, "A").End(xlUp).Row
    For i = 2 To lgLastRow
        If wsCat.Cells(i, 1).Value <> "" Then
            objCatDict(Trim(LCase(wsCat.Cells(i, 1).Value))) = wsCat.Cells(i, 2).Interior.Color
        End If
    Next i

    For Each objSeries In objChart.SeriesCollection ' Parcourt toutes les séries du graphique
        strCatName = Trim(LCase(objSeries.Name))
        If objCatDict.exists(strCatName) Then
            objSeries.Format.Fill.ForeColor.RGB = objCatDict(strCatName)
        Else
            For j = 1 To objSeries.Points.Count
                strCatName = Trim(LCase(objSeries.XValues(j))) ' On uniformise la casse et supprime les espaces
                If objCatDict.exists(strCatName) Then
                    objSeries.Points(j).Format.Fill.ForeColor.RGB = objCatDict(strCatName)
                Else
                    If GreyOtherBar Then objSeries.Points(j).Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
                End If
            Next j
        End If
    Next objSeries
    Set objChart = Nothing
    Set wsCat = Nothing
    Set objCatDict = Nothing

    MsgBox "Couleurs mises à jour pour le graphique sélectionné.", vbInformation
    Exit Sub
erreur:
    MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur ColorierBarresHistogramme"
End Sub

2 constantes au début pour préciser le nom de la feuille donnant le nom et la couleur des catégorie et s'il faut griser les catégories inconnues

Tu sélectionnes le graphique puis tu exécutes la macro.
 

Pièces jointes

Vote positif 0 Vote négatif
Bonjour MLGARIN, bienvenue sur XLD, hello Hecatonchire,

Voici une solution très simple avec cette macro dans ThisWorkbook :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.ChartObjects.Count = 0 Then Exit Sub
Dim co As ChartObject, a, i&
Application.ScreenUpdating = False
For Each co In Sh.ChartObjects
    If co.Chart.ChartType = xlColumnClustered Then 'histogramme
        With co.Chart.SeriesCollection(1)
            a = .XValues
            For i = 1 To .Points.Count
                .Points(i).Format.Fill.ForeColor.RGB = Sh.Cells.Find(a(i), , xlValues).Interior.Color
            Next i
        End With
    End If
Next co
End Sub
Pour chaque graphique histogramme il suffit de colorer les cellules définissant l'axe des abscisses.

Le formatage d'une cellule ne créant pas d'évènement, il faut valider ou modifier une cellule quelconque.

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Ceci est mieux car c'est plus fiable :
VB: 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.ChartObjects.Count = 0 Then Exit Sub
Dim co As ChartObject, a As Range, i&
Application.ScreenUpdating = False
For Each co In Sh.ChartObjects
    If co.Chart.ChartType = xlColumnClustered Then 'histogramme
        With co.Chart.SeriesCollection(1)
            Set a = Evaluate(Split(.Formula, ",")(1))
            For i = 1 To .Points.Count
                .Points(i).Format.Fill.ForeColor.RGB = a(i).Interior.Color
            Next i
        End With
    End If
Next co
End Sub
 

Pièces jointes

Vote positif 0 Vote négatif
Hecatonchire à dit:
Bonjour,

Je te propose cette macro

VB: 
Sub ColorierBarresHistogramme()
    Const FeuilleParam  As String = "Catégories"
    Const GreyOtherBar  As Boolean = False
    
    Dim objChart        As chart
    Dim objSeries       As Series
    Dim i               As Long, j As Long
    Dim wsCat           As Worksheet
    Dim objCatDict      As Object
    Dim lgLastRow       As Long
    Dim strCatName      As String
    Dim boByCategorie   As Boolean
    
    On Error GoTo erreur
    If TypeName(Selection) <> "ChartArea" And TypeName(Selection) <> "PlotArea" Then
        MsgBox "Veuillez sélectionner le graphique (histogramme) à modifier.", vbExclamation
        Exit Sub
    End If

    Set objChart = ActiveChart ' Récupère le graphique sélectionné
    Set wsCat = ActiveWorkbook.Sheets(FeuilleParam)
    Set objCatDict = CreateObject("Scripting.Dictionary") ' Création du dictionnaire

    lgLastRow = wsCat.Cells(70000, "A").End(xlUp).Row
    For i = 2 To lgLastRow
        If wsCat.Cells(i, 1).Value <> "" Then
            objCatDict(Trim(LCase(wsCat.Cells(i, 1).Value))) = wsCat.Cells(i, 2).Interior.Color
        End If
    Next i

    For Each objSeries In objChart.SeriesCollection ' Parcourt toutes les séries du graphique
        strCatName = Trim(LCase(objSeries.Name))
        If objCatDict.exists(strCatName) Then
            objSeries.Format.Fill.ForeColor.RGB = objCatDict(strCatName)
        Else
            For j = 1 To objSeries.Points.Count
                strCatName = Trim(LCase(objSeries.XValues(j))) ' On uniformise la casse et supprime les espaces
                If objCatDict.exists(strCatName) Then
                    objSeries.Points(j).Format.Fill.ForeColor.RGB = objCatDict(strCatName)
                Else
                    If GreyOtherBar Then objSeries.Points(j).Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
                End If
            Next j
        End If
    Next objSeries
    Set objChart = Nothing
    Set wsCat = Nothing
    Set objCatDict = Nothing

    MsgBox "Couleurs mises à jour pour le graphique sélectionné.", vbInformation
    Exit Sub
erreur:
    MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur ColorierBarresHistogramme"
End Sub

2 constantes au début pour préciser le nom de la feuille donnant le nom et la couleur des catégorie et s'il faut griser les catégories inconnues

Tu sélectionnes le graphique puis tu exécutes la macro.
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Comme je suis très très novice sur les macros... comment je fais pour enregistrer ta macro dans mon catalogue de macro ?? Parce que là cela fonctionne sans souci (et ça c'est une super nouvelle) mais uniquement lorsque ton fichier excel est ouvert. Comment je fais pour recopier ta macro et l'enregistrer pour pouvoir l'utiliser dans n'importe quel fichier à l'avenir ? Merci pour ton aide !!
 
Vote positif 0 Vote négatif
Hecatonchire à dit:
Bonjour,

Je te propose cette macro

VB: 
Sub ColorierBarresHistogramme()
    Const FeuilleParam  As String = "Catégories"
    Const GreyOtherBar  As Boolean = False
    
    Dim objChart        As chart
    Dim objSeries       As Series
    Dim i               As Long, j As Long
    Dim wsCat           As Worksheet
    Dim objCatDict      As Object
    Dim lgLastRow       As Long
    Dim strCatName      As String
    Dim boByCategorie   As Boolean
    
    On Error GoTo erreur
    If TypeName(Selection) <> "ChartArea" And TypeName(Selection) <> "PlotArea" Then
        MsgBox "Veuillez sélectionner le graphique (histogramme) à modifier.", vbExclamation
        Exit Sub
    End If

    Set objChart = ActiveChart ' Récupère le graphique sélectionné
    Set wsCat = ActiveWorkbook.Sheets(FeuilleParam)
    Set objCatDict = CreateObject("Scripting.Dictionary") ' Création du dictionnaire

    lgLastRow = wsCat.Cells(70000, "A").End(xlUp).Row
    For i = 2 To lgLastRow
        If wsCat.Cells(i, 1).Value <> "" Then
            objCatDict(Trim(LCase(wsCat.Cells(i, 1).Value))) = wsCat.Cells(i, 2).Interior.Color
        End If
    Next i

    For Each objSeries In objChart.SeriesCollection ' Parcourt toutes les séries du graphique
        strCatName = Trim(LCase(objSeries.Name))
        If objCatDict.exists(strCatName) Then
            objSeries.Format.Fill.ForeColor.RGB = objCatDict(strCatName)
        Else
            For j = 1 To objSeries.Points.Count
                strCatName = Trim(LCase(objSeries.XValues(j))) ' On uniformise la casse et supprime les espaces
                If objCatDict.exists(strCatName) Then
                    objSeries.Points(j).Format.Fill.ForeColor.RGB = objCatDict(strCatName)
                Else
                    If GreyOtherBar Then objSeries.Points(j).Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
                End If
            Next j
        End If
    Next objSeries
    Set objChart = Nothing
    Set wsCat = Nothing
    Set objCatDict = Nothing

    MsgBox "Couleurs mises à jour pour le graphique sélectionné.", vbInformation
    Exit Sub
erreur:
    MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur ColorierBarresHistogramme"
End Sub

2 constantes au début pour préciser le nom de la feuille donnant le nom et la couleur des catégorie et s'il faut griser les catégories inconnues

Tu sélectionnes le graphique puis tu exécutes la macro.
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Hecatonchire à dit:
Bonjour,

Je te propose cette macro

VB: 
Sub ColorierBarresHistogramme()
    Const FeuilleParam  As String = "Catégories"
    Const GreyOtherBar  As Boolean = False
    
    Dim objChart        As chart
    Dim objSeries       As Series
    Dim i               As Long, j As Long
    Dim wsCat           As Worksheet
    Dim objCatDict      As Object
    Dim lgLastRow       As Long
    Dim strCatName      As String
    Dim boByCategorie   As Boolean
    
    On Error GoTo erreur
    If TypeName(Selection) <> "ChartArea" And TypeName(Selection) <> "PlotArea" Then
        MsgBox "Veuillez sélectionner le graphique (histogramme) à modifier.", vbExclamation
        Exit Sub
    End If

    Set objChart = ActiveChart ' Récupère le graphique sélectionné
    Set wsCat = ActiveWorkbook.Sheets(FeuilleParam)
    Set objCatDict = CreateObject("Scripting.Dictionary") ' Création du dictionnaire

    lgLastRow = wsCat.Cells(70000, "A").End(xlUp).Row
    For i = 2 To lgLastRow
        If wsCat.Cells(i, 1).Value <> "" Then
            objCatDict(Trim(LCase(wsCat.Cells(i, 1).Value))) = wsCat.Cells(i, 2).Interior.Color
        End If
    Next i

    For Each objSeries In objChart.SeriesCollection ' Parcourt toutes les séries du graphique
        strCatName = Trim(LCase(objSeries.Name))
        If objCatDict.exists(strCatName) Then
            objSeries.Format.Fill.ForeColor.RGB = objCatDict(strCatName)
        Else
            For j = 1 To objSeries.Points.Count
                strCatName = Trim(LCase(objSeries.XValues(j))) ' On uniformise la casse et supprime les espaces
                If objCatDict.exists(strCatName) Then
                    objSeries.Points(j).Format.Fill.ForeColor.RGB = objCatDict(strCatName)
                Else
                    If GreyOtherBar Then objSeries.Points(j).Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
                End If
            Next j
        End If
    Next objSeries
    Set objChart = Nothing
    Set wsCat = Nothing
    Set objCatDict = Nothing

    MsgBox "Couleurs mises à jour pour le graphique sélectionné.", vbInformation
    Exit Sub
erreur:
    MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur ColorierBarresHistogramme"
End Sub

2 constantes au début pour préciser le nom de la feuille donnant le nom et la couleur des catégorie et s'il faut griser les catégories inconnues

Tu sélectionnes le graphique puis tu exécutes la macro.
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
Bonjour MLGARIN,

Voici une V2
Par catégorie/série, tu indiques dans la feuille Catégories (à partir de A2) :
  • Pour les graphique de type Courbe, Nuage de points ... : Couleur de bordure, épaisseur de bordure
  • Pour les autres : Couleur de remplissage, hachure, couleur de hachure
Dans le tableau en F2 (TabListeGraphs) : la liste des graphiques à modifier
Le tableau en J2 est pour le code

En début de code tu peux personnaliser les valeurs de STR_SHEET_PARAM et BO_GREY_OTHER_BAR

Le code ne fonctionne pas pour les graphiques Compartimentage, Rayons de soleil, Cascade, Entonnoir, Boîte à moustaches, Histogramme, certains des boursiers

(J'ai laissé les graphiques de tests, tu peux les supprimer)

Edit : Le code de Module2 ne sert à rien ( a supprimer/ignorer)
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Bonjour le forum,

Voyez le fichier joint et ces macros :
VB: 
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Workbook_SheetChange Sh, Sh.[A1] 'lance la macro
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.ChartObjects.Count = 0 Then Exit Sub
Dim co As ChartObject, a As Range, i&
Application.ScreenUpdating = False
For Each co In Sh.ChartObjects
    If co.Chart.ChartType = xlColumnClustered Then 'histogramme
        With co.Chart.SeriesCollection(1)
            Set a = Evaluate(Split(.Formula, ",")(1))
            For i = 1 To .Points.Count
                With .Points(i).Format.Fill
                    If a(i)(1, 3) Then 'n° en 3ème colonne
                        .Patterned a(i)(1, 3)
                        .ForeColor.RGB = vbBlack
                        .BackColor.RGB = a(i).Interior.Color
                    Else
                        .Solid
                        .ForeColor.RGB = a(i).Interior.Color
                    End If
                End With
            Next i
        End With
    End If
Next co
End Sub
Le numéro de motif à appliquer est en colonne C.

Il faut noter qu'il n'a rien à voir avec les numéros de motifs appliqués aux cellules.

A+
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Bonjour MLGARIN,

Une V3 avec une organisation plus logique des paramètres de formatage (d'un coté le remplissage, de l'autre les bordures), la possibilité de formater la couleur de fond et la couleur de bordure en même temps, la possibilité de ne pas modifier le formatage existant et quelques contrôle de sécurité en plus.

Pour ne pas modifier le formatage existant il suffit de choisir :
> Aucun remplissage pour la couleur de fond et de bordure (pour du blanc choisir couleur blanche)
> Couleur de police Automatique pour les hachures (pour du noir choisir couleur noire)
> Valeur vide pour l'épaisseur de bordure

La valeur 0 pour l'épaisseur de bordure permet de supprimer la bordure
 

Pièces jointes

Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

L
  • Question Question
Microsoft 365 Changement de couleurs de cellules dans plusieurs feuilles suite à une modification
Réponses
4
Affichages
696
lolo_excelbeginner
L
kan3pz
  • Question Question
XL 2010 Attribuer des couleurs définies à des graphiques
Réponses
3
Affichages
955
kan3pz
kan3pz
J
  • Question Question
classer des nombres de plusieurs feuilles sur une seule colonne sur une seule fiche
2
Réponses
19
Affichages
2 K
jmb75018
J
M
[REF] Wiki 1 de MichelXld (Généralités Excel)
Réponses
6
Affichages
60 K
Le_Phénomène
Le_Phénomène
Retour