Demande initiale de l'utilisatrice : Une macro permettant d'uniformiser la couleur de remplissage de plusieurs graphiques.
1ère idée : Utiliser un modèle de graphique (.crtx)
- Les graphiques doivent être du même type.
- L'ordre des séries et catégorie doit être le même pour tous les graphiques.
2ème idée : Utiliser un thème ou une palette de couleurs
- Fonctionne bien pour les couleurs de remplissage et de bordure
- Nombre de couleurs limité (10 couleurs + 5*10 variations).
- Pas de possibilité de gérer des hachures ou une épaisseur de trait (demande de l'utilisatrice).
3ème idée : Utiliser du VBA (macro)
Principe
Via une feuille de paramétrages on va donner au code les informations de formatage désirées ainsi que la liste des graphiques à modifier.
Utilisation
- Remplir la liste des graphiques à formater via le tableau "TabListeGraphs" dans la feuille désignée par STR_SHEET_PARAM.
- La 1ère colonne donne le nom de la feuille où se trouve le graphique,
- La 2ème colonne le nom du graphique,
- Attention : Il faut forcément renommer tous les graphiques (via le volet Sélection -Ruban Accueil>Rechercher et sélectionner (groupe Édition)) sinon les noms "externes" ne correspondront pas forcément à leurs noms "internes" (exemple : "Graphique 1" s'appellera "Graph 1" en interne).
- À partir de la cellule A2, B2, C2 de la feuille désignée par STR_SHEET_PARAM, saisir :
- En colonne A : Le nom des séries ou des catégories,
- En colonne B : L'épaisseur de la bordure (facultatif) et remplir la cellule de la couleur de bordure ou de remplissage à utiliser.
- En colonne C : Le nom de la hachure à utiliser en remplissage et utiliser.
Le code
Option Explicit
Dim TAB_TYPE_BORDERS ' Liste des graphiques où la couleur correspond à la bordure
Dim TAB_GRAPH_HS ' Liste des graphiques non compatibles
Dim DIC_FORMATAGE As Object
Const STR_SHEET_PARAM As String = "Catégories" ' Nom de la feuille de paramétrage
Const BO_GREY_OTHER_BAR As Boolean = False ' Si True, le code grise les catégories inconnues
' Si False, le code ne modifie pas les catégories inconnues
Sub FormatAllGraph()
' Objectif : Formater de manière uniforme plusieurs graphiques en se basant sur le nom des séries et catégories
' Utilisation : Dresser les listes des graphiques à modifier et des formatages à appliquer puis lancer la macro.
' Retour : Néant.
' Auteur : Arnaud (www.1forme.fr).
' Licence : CC-BY-NC-SA (Vous pouvez diffuser/partager/modifier cette macro dans les
' même conditions, seulement à titre personnel et citant l'auteur/site d'origine.
Const TabListeGraphs As String = "TabListeGraphs" ' Nom du tableau des graphiques à modifier
' Toujours les renommer via le volet de sélection
Dim objSheetParam As Worksheet ' Feuille de paramétrage
Dim objLo As ListObject ' Tableau des graphiques à modifier
Dim rgCell As Range '
Dim lgLastRow As Long ' Dernière ligne du tableau en A2 dans STR_SHEET_PARAM
Dim TabFormatage(1 To 5) ' Couleur de fond, type de hachure, couleur des hachures, épaisseur de bordure, couleur de bordure
Dim i As Long
On Error GoTo erreur
'Application.ScreenUpdating = False
Set DIC_FORMATAGE = Nothing
TAB_TYPE_BORDERS = Array(xlLine, xlLineMarkers, xlLineStacked, _
xlLineMarkersStacked, xlLineMarkersStacked100, _
xlXYScatterLines, xlXYScatterLinesNoMarkers, _
xlXYScatterSmooth, xlXYScatterSmoothNoMarkers, _
xlRadar, xlRadarMarkers, xlSurfaceWireframe)
TAB_GRAPH_HS = Array(xlWaterfall, xlFunnel, xlTreemap, xlSunburst, xlHistogram, _
xlSurface, xlSurfaceWireframe, xlSurfaceTopView, xlSurfaceTopViewWireframe, _
xlBoxwhisker, xlPareto)
On Error Resume Next
Set objSheetParam = ActiveWorkbook.Worksheets(STR_SHEET_PARAM)
If objSheetParam Is Nothing Then _
MsgBox "La feuille de paramétrage '" & STR_SHEET_PARAM & "' n'est pas présente !", _
vbCritical, "Exécution impossible": Exit Sub
On Error GoTo erreur
lgLastRow = objSheetParam.Cells(70000, "A").End(xlUp).Row
Set DIC_FORMATAGE = CreateObject("Scripting.Dictionary") ' Création du dictionnaire
With objSheetParam
For i = 2 To lgLastRow ' Remplissage du dictionnaire
If .Cells(i, 1).Value <> "" Then
TabFormatage(1) = IIf(.Cells(i, 2).Interior.Pattern = xlNone, -1, .Cells(i, 2).Interior.Color) ' Couleur de fond
TabFormatage(2) = IIf(.Cells(i, 2).Value = "", "", GetPatternValueFromTable(.Cells(i, 2).Value)) ' Type de hachure
TabFormatage(3) = IIf(.Cells(i, 2).Font.ColorIndex = xlAutomatic, -1, .Cells(i, 2).Font.Color) ' Couleur de hachure
TabFormatage(4) = .Cells(i, 3).Value ' Epaisseur de bordure
TabFormatage(5) = IIf(.Cells(i, 3).Interior.Pattern = xlNone, -1, .Cells(i, 3).Interior.Color) ' Couleur de bordure
If TabFormatage(4) < 0 Or TabFormatage(4) > 1584 Then _
MsgBox "L'épaisseur doit être entre 0 et 1584 pour " & .Cells(i, 1).Value, _
vbCritical, "Valeur non utilisable": Exit Sub
DIC_FORMATAGE(Trim(LCase(.Cells(i, 1).Value))) = TabFormatage()
End If
Next i
On Error Resume Next
Set objLo = .ListObjects(TabListeGraphs)
If objLo Is Nothing Then _
MsgBox "La liste de graphique '" & TabListeGraphs & "' n'est pas présent dans '" & _
STR_SHEET_PARAM & "' !", vbCritical, "Exécution impossible": Exit Sub
On Error GoTo erreur
End With
' Boucle sur la liste des graphiques à modifier
For Each rgCell In objLo.ListColumns(1).DataBodyRange
Call FormatAGraph(rgCell.Value, rgCell.Offset(0, 1).Value, objSheetParam, lgLastRow)
Next rgCell
Set objLo = Nothing
Set DIC_FORMATAGE = Nothing
Set objSheetParam = Nothing
MsgBox "Couleurs mises à jour pour les graphiques désignés.", vbInformation
Exit Sub
erreur:
MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur FormatAllGraph"
End Sub
Sub FormatAGraph(strSheetName As String, strGraphName As String, objSheetParam As Object, lgLastRow As Long)
' Procédure de formatage d'un graphique unique
Dim objChart As ChartObject ' Le graphique
Dim objSeries As Series ' Les séries du graphique
Dim j As Long
Dim strCatName As String ' Nom de la catégorie ou de la série
Dim boChartTypesBorders As Boolean ' Flag graphique où la couleur correspond à la bordure
On Error Resume Next
Set objChart = ActiveWorkbook.Worksheets(strSheetName).ChartObjects(strGraphName)
If Not objChart Is Nothing Then
If Not IsChartTypeInList(objChart.chart.chartType, TAB_GRAPH_HS) Then
On Error GoTo erreur
For Each objSeries In objChart.chart.SeriesCollection ' Parcourt toutes les séries du graphique
boChartTypesBorders = IsChartTypeInList(objSeries.chartType, TAB_TYPE_BORDERS) ' Test Remplissage ou bordure
strCatName = Trim(LCase(objSeries.Name)) ' On uniformise la casse et supprime les espaces
If DIC_FORMATAGE.exists(strCatName) Then ' Cas traitement par série
Call FormatItem(boChartTypesBorders, strCatName, objSeries)
Else ' Cas traitement par catégorie
For j = 1 To objSeries.Points.Count ' Parcourt des catégories
strCatName = Trim(LCase(objSeries.XValues(j)))
If DIC_FORMATAGE.exists(strCatName) Then ' Catégorie référencée
Call FormatItem(boChartTypesBorders, strCatName, objSeries.Points(j))
Else ' Catégorie non référencée
If BO_GREY_OTHER_BAR And Not boChartTypesBorders Then _
objSeries.Points(j).Format.Fill.ForeColor.RGB = RGB(200, 200, 200)
End If
Next j
End If
Next objSeries
End If
Set objChart = Nothing
End If
Exit Sub
erreur:
MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur FormatAGraph"
End Sub
Sub FormatItem(boChartTypesBorders As Boolean, strCatName As String, objToFormat As Object)
' Procédure de formatage d'un élément d'un graphique (série ou catégorie)
On Error GoTo erreur
If boChartTypesBorders Then ' Formatage seulement des bordures
With objToFormat.Format.Line
If DIC_FORMATAGE(strCatName)(5) <> -1 Then .ForeColor.RGB = DIC_FORMATAGE(strCatName)(5)
If DIC_FORMATAGE(strCatName)(4) <> "" Then
If DIC_FORMATAGE(strCatName)(4) = 0 Then
.Visible = msoFalse
Else
.Visible = msoTrue
.Weight = DIC_FORMATAGE(strCatName)(4)
End If
End If
End With
Else ' Formatage du remplissage et des bordures
With objToFormat.Format.Fill
If DIC_FORMATAGE(strCatName)(2) <> "" Then ' Hachure précisés => modification hachures
If DIC_FORMATAGE(strCatName)(2) = 0 Then ' Supprime hachures
.Solid
Else
.Patterned DIC_FORMATAGE(strCatName)(2) ' Modifie hachures
End If
End If
If DIC_FORMATAGE(strCatName)(1) <> -1 Then ' Fond pas en Aucun remplissage => Modification couleur fond
If DIC_FORMATAGE(strCatName)(2) <> "" Or .Pattern <> msoPatternMixed Then ' Avec hachures
.BackColor.RGB = DIC_FORMATAGE(strCatName)(1)
Else ' Sans hachures
.ForeColor.RGB = DIC_FORMATAGE(strCatName)(1) ' Sans hachure ForeColor
End If
End If
If DIC_FORMATAGE(strCatName)(3) <> -1 Then ' Couleur pas en Automatique => Modif couleur hachures
.ForeColor.RGB = DIC_FORMATAGE(strCatName)(3)
End If
End With
With objToFormat.Format.Line
If DIC_FORMATAGE(strCatName)(5) <> -1 Then .ForeColor.RGB = DIC_FORMATAGE(strCatName)(5)
If DIC_FORMATAGE(strCatName)(4) <> "" Then
If DIC_FORMATAGE(strCatName)(4) = 0 Then
.Visible = msoFalse
Else
.Visible = msoTrue
.Weight = DIC_FORMATAGE(strCatName)(4)
End If
End If
End With
End If
Exit Sub
erreur:
MsgBox Err.Description & "(" & Err.Number & ")", vbCritical, "Erreur FormatItem"
End Sub
Function IsChartTypeInList(chartType As XlChartType, typeList As Variant) As Boolean
' Cherche si un type de graphique est dans une liste
Dim t
For Each t In typeList
If chartType = t Then IsChartTypeInList = True: Exit Function
Next
End Function
Function GetPatternValueFromTable(StrNomConstante As String) As Variant
' Conversion NomHachure/Valeur
Dim objTabConstHachures As ListObject
Dim tabData As Variant
Dim i As Long
Set objTabConstHachures = ActiveWorkbook.Sheets(STR_SHEET_PARAM).ListObjects("TabConstHachures")
tabData = objTabConstHachures.DataBodyRange.Value ' Charge tout dans un tableau (1 to n, 1 to 3)
For i = 1 To UBound(tabData, 1)
If tabData(i, 1) = StrNomConstante Then
GetPatternValueFromTable = tabData(i, 2): Exit Function
End If
Next
GetPatternValueFromTable = "" ' Si non trouvé
End FunctionMerci pour votre attention bienveillante.
