EXCEL :: VBA :: Barre de progression via un graphique cylindrique, cubique, aquarium, donuts et shape

oguruma · 2 Avril 2025

Bonjour,
Une version améliorée de la version initiale ICI.

Avant d'aller plus loin dans les détails : si vous souhaitez implémenter ces barres à partir d'une nouvelle application, nouveau classeur Excel dans lequel vous aurez besoin de piloter certains traitements il est recommandé de partir de ce classeur où tout déjà prévu, le sauvegarder sous le nom de votre nouveau classeur... puis adapter les procédures d'affichage selon vos besoin
En revanche pour implémenter ces jauges graphiques dans une application existante :
- il faudra reconstruire la feuille de paramétrage et de préférence attribuer les mêmes noms de champ pour ne pas les modifier dans les modules VBA livrés
- puis copier les graphiques (copier/coller)
- ET casser la liaison avec le classeur source
- ET réaffecter les séries sur le tableau de paramétrage que vous aurez recréé
Ce n'est pas du clef en main... je sais...
Mais ça prend moins de 10 minutes chrono pour refaire le paramétrage complet avec un peu d'expérience.... recopier uniquement le graphique qui vous intéresse et adapter les procédures en spécifiant le nom du graphique dans les procédures VBA... ça n'est pas compliqué 🙂
Exemple pour "BAR_GRAPHIC_2"

VB:

Set oGraphBarChart = LOAD_GRAPH_PROGRESS_BAR("Feuil2", "E10", "BAR_GRAPHIC_2")

ou dans les modules de chargement changer la valeur par défaut et préciser votre propre nom
exemple "BAR_GRAPHIC" ==> le nom de votre graphique - cependant nommé votre seul et unique graphique comme celui-ci... et vous n'aurez pas besoin de modifier les modules...

Allez en gros il y a une petite heure de boulot GRAND MAXI pour cadrer, tester tout cela....

VB:

Function LOAD_GRAPH_PROGRESS_BAR(hDestWks As String, hAddress As String, _
Optional hGraph As String = "BAR_GRAPHIC", Optional hSourceWks As String = "PARAM_BAR") As Variant

Une amélioration conséquente, on dispose des libellés des axes X et Y pour documenter plus en détails les traitements effectués. Je vous laisse faire la comparaison par rapport à la version initiale.

Dans cette nouvelle version on dispose des formes suivantes

et enfin une Shape

afin de monter la progression des traitement on joue sur la transparence

on a 3 emplacements pour afficher le détail des traitements

Désolé pour le choix des couleurs je n'ai pas l'école des beaux Arts 😀
Code complet concernant les graphiques

VB:

Option Explicit

Global oSpeedMacro As SpeedMacro

Sub TEST_LOAD_GRAPH_PROGRESS_2()
    Dim oGraphBarChart As ChartObject
    Set oGraphBarChart = LOAD_GRAPH_PROGRESS_BAR("Feuil2", "E5", "BAR_GRAPHIC_3")
    If Not oGraphBarChart Is Nothing Then Debug.Print oGraphBarChart.Name
End Sub

Sub TEST_UNLOAD_GRAPH_PROGRESS_2()
    Debug.Print UNLOAD_GRAPH_PROGRESS_BAR("BAR_GRAPHIC_3")
End Sub

Sub TEST_CHANGE_GRAPH_XL_VALUE_1()
    Debug.Print CHANGE_GRAPH_XL_VALUE()
End Sub

Sub TEST_CHANGE_GRAPH_XL_CATEGORY_1()
    Debug.Print CHANGE_GRAPH_XL_CATEGORY()
End Sub

Sub INIT_CHANGE_GRAPH_XL_VALUE_2()
    Debug.Print CHANGE_GRAPH_XL_VALUE("BAR_GRAPHIC_2", , "YYYYY")
End Sub

Sub INIT_CHANGE_GRAPH_XL_CATEGORY_2()
    Debug.Print CHANGE_GRAPH_XL_CATEGORY("BAR_GRAPHIC_2", , "")
End Sub

Sub TEST_PROGRESS_BAR_1()
    Dim oGraphBarChart As ChartObject
    Dim lngIdx As Long
   
    Set oGraphBarChart = LOAD_GRAPH_PROGRESS_BAR("Feuil2", "E10")
    If oGraphBarChart Is Nothing Then
        MsgBox "Impossible de charger la barre de progression"
        Exit Sub
    Else
       ' Debug.Print oGraphBarChart.Name
    End If
   
    Call INIT_GRAPH_KPI_2_ZERO
    Call INIT_MSG_PROGRESS_BAR
    Call INIT_CHANGE_GRAPH_XL_VALUE_CATEGORY
   
    For lngIdx = 0 To 300
        '
        ' ==> ici vos traitements...
        '
        Range("MSG_TITRE") = "Traitement " & CStr(lngIdx)
        Range("GRAPH_X_LIBELLE") = "Traitement " & CStr(lngIdx)
        Range("INFO_AXE_Y") = "Traitement " & CStr(lngIdx)
        Range("INFO_AXE_X") = "Traitement " & CStr(lngIdx)
        Call CHANGE_GRAPH_XL_VALUE("BAR_GRAPHIC", , "Mon info de traitement " & CStr(lngIdx))
        Call CHANGE_GRAPH_XL_CATEGORY("BAR_GRAPHIC")
        Range("GRAPH_KPI") = lngIdx / 300
        oGraphBarChart.Chart.Refresh ' on refresh par sécurité après
        DoEvents
    Next

    MsgBox "Traitements terminés"

    Call INIT_GRAPH_KPI_2_ZERO
    Call INIT_DEFAUT_MSG_PROGRESS_BAR
   
    If Not UNLOAD_GRAPH_PROGRESS_BAR() Then
        MsgBox "Impossible de supprimer la barre de progression"
    End If
   
FIN:
    Exit Sub
   
HANDLE_ERROR:
    MsgBox "incident n° " & Err.Number & " - " & Err.Description
    Resume FIN
End Sub


Sub TEST_PROGRESS_BAR_2()
    Dim oGraphBarChart As ChartObject
    Dim lngIdx As Long
   
    Set oGraphBarChart = LOAD_GRAPH_PROGRESS_BAR("Feuil2", "E10", "BAR_GRAPHIC_2")
    If oGraphBarChart Is Nothing Then
        MsgBox "Impossible de charger la barre de progression"
        Exit Sub
    Else
       ' Debug.Print oGraphBarChart.Name
    End If
   
    Call INIT_GRAPH_KPI_2_ZERO
    Call INIT_MSG_PROGRESS_BAR
    Call INIT_CHANGE_GRAPH_XL_VALUE_CATEGORY
   
    For lngIdx = 0 To 300
        '
        ' ==> ici vos traitements...
        '
        Range("MSG_TITRE") = "Traitement " & CStr(lngIdx)
        Range("GRAPH_X_LIBELLE") = "Traitement " & CStr(lngIdx)
        Range("INFO_AXE_Y") = "Traitement " & CStr(lngIdx)
        Range("INFO_AXE_X") = "Traitement " & CStr(lngIdx)
'        Call CHANGE_GRAPH_XL_VALUE("BAR_GRAPHIC_2", , "Mon info de traitement " & CStr(lngIdx))
'        Call CHANGE_GRAPH_XL_CATEGORY("BAR_GRAPHIC_2")
        Range("GRAPH_KPI") = lngIdx / 300
        oGraphBarChart.Chart.Refresh ' on refresh par sécurité après
        DoEvents
    Next

    MsgBox "Traitements terminés"

    Call INIT_GRAPH_KPI_2_ZERO
    Call INIT_DEFAUT_MSG_PROGRESS_BAR
   
    If Not UNLOAD_GRAPH_PROGRESS_BAR("BAR_GRAPHIC_2") Then
        MsgBox "Impossible de supprimer la barre de progression"
    End If
   
FIN:
    Exit Sub
   
HANDLE_ERROR:
    MsgBox "incident n° " & Err.Number & " - " & Err.Description
    Resume FIN
End Sub


Sub TEST_PROGRESS_BAR_3()
    Dim oGraphBarChart As ChartObject
    Dim lngIdx As Long
   
    Set oGraphBarChart = LOAD_GRAPH_PROGRESS_BAR("Feuil2", "E10", "BAR_GRAPHIC_3")
    If oGraphBarChart Is Nothing Then
        MsgBox "Impossible de charger la barre de progression"
        Exit Sub
    Else
       ' Debug.Print oGraphBarChart.Name
    End If
   
    Call INIT_GRAPH_KPI_2_ZERO
 
    For lngIdx = 0 To 300
        '
        ' ==> ici vos traitements...
        '
        Range("GRAPH_X_LIBELLE") = "Traitement " & CStr(lngIdx)
        Range("GRAPH_KPI") = lngIdx / 300
        oGraphBarChart.Chart.Refresh ' on refresh par sécurité après
        DoEvents
    Next

    MsgBox "Traitements terminés"
    Call INIT_GRAPH_KPI_2_ZERO
    Range("GRAPH_X_LIBELLE") = "<DEFAUT>"
   
    If Not UNLOAD_GRAPH_PROGRESS_BAR("BAR_GRAPHIC_3") Then
        MsgBox "Impossible de supprimer la barre de progression"
    End If
   
FIN:
    Exit Sub
   
HANDLE_ERROR:
    MsgBox "incident n° " & Err.Number & " - " & Err.Description
    Resume FIN
End Sub


Sub TEST_PROGRESS_BAR_4()
    Dim oGraphBarChart As ChartObject
    Dim lngIdx As Long
   
    Set oGraphBarChart = LOAD_GRAPH_PROGRESS_BAR("Feuil2", "E5", "BAR_GRAPHIC_4")
    If oGraphBarChart Is Nothing Then
        MsgBox "Impossible de charger la barre de progression"
        Exit Sub
    Else
       ' Debug.Print oGraphBarChart.Name
    End If
   
    Call INIT_GRAPH_KPI_2_ZERO
 
    For lngIdx = 0 To 300
        '
        ' ==> ici vos traitements...
        '
        Range("GRAPH_X_LIBELLE") = "Traitement " & CStr(lngIdx)
        Range("GRAPH_KPI") = lngIdx / 300
        oGraphBarChart.Chart.Refresh ' on refresh par sécurité après
        DoEvents
    Next

    MsgBox "Traitements terminés"
    Call INIT_GRAPH_KPI_2_ZERO
    Range("GRAPH_X_LIBELLE") = "<DEFAUT>"
   
    If Not UNLOAD_GRAPH_PROGRESS_BAR("BAR_GRAPHIC_4") Then
        MsgBox "Impossible de supprimer la barre de progression"
    End If
   
FIN:
    Exit Sub
   
HANDLE_ERROR:
    MsgBox "incident n° " & Err.Number & " - " & Err.Description
    Resume FIN
End Sub

Function LOAD_GRAPH_PROGRESS_BAR(hDestWks As String, hAddress As String, _
Optional hGraph As String = "BAR_GRAPHIC", Optional hSourceWks As String = "PARAM_BAR") As Variant
 
    Dim oGraphBarChart As ChartObject
    Dim oGraphBarChartArea As ChartArea
   
    Set LOAD_GRAPH_PROGRESS_BAR = Nothing
   
    On Error GoTo HANDLE_ERROR
   
    Set oGraphBarChart = ActiveWorkbook.Worksheets(hSourceWks).ChartObjects(hGraph)
    oGraphBarChart.Activate
   
    Set oGraphBarChartArea = ActiveChart.ChartArea
   
    oGraphBarChartArea.Copy

    ActiveWorkbook.Worksheets(hDestWks).Activate
    Range(hAddress).Activate
    ActiveSheet.Paste

    Range("A1").Activate
   
    Set LOAD_GRAPH_PROGRESS_BAR = oGraphBarChart
   
FIN:
    Set oGraphBarChart = Nothing
    Set oGraphBarChartArea = Nothing
    Exit Function

HANDLE_ERROR:
    Resume FIN

End Function

Function UNLOAD_GRAPH_PROGRESS_BAR(Optional hGraph As String = "BAR_GRAPHIC", Optional hDestWks As String = "ActiveSheet") As Boolean
 
    Dim oGraphBarChart As ChartObject
    Dim wk As Worksheet
   
    UNLOAD_GRAPH_PROGRESS_BAR = False
   
    On Error GoTo HANDLE_ERROR
   
    If hDestWks = "ActiveSheet" Then Set wk = ActiveSheet Else Set wk = ActiveWorkbook.Worksheets(hDestWks)
   
    Set oGraphBarChart = wk.ChartObjects(hGraph)
    oGraphBarChart.Activate
   
    oGraphBarChart.Delete
   
    UNLOAD_GRAPH_PROGRESS_BAR = True
   
FIN:
    Set oGraphBarChart = Nothing
    Exit Function

HANDLE_ERROR:
    Resume FIN

End Function

Function CHANGE_GRAPH_XL_VALUE(Optional hGraph As String = "BAR_GRAPHIC", _
Optional hSourceWks As String = "PARAM_BAR", _
Optional hValue As Variant) As Boolean
 
    Dim oGraphBarChart As ChartObject
    Dim oAxis As Axis
   
    CHANGE_GRAPH_XL_VALUE = False
   
    On Error GoTo HANDLE_ERROR
   
   ' Set oGraphBarChart = ActiveWorkbook.Worksheets(hSourceWks).ChartObjects(hGraph)
   Set oGraphBarChart = ActiveWorkbook.ActiveSheet.ChartObjects(hGraph)
    oGraphBarChart.Activate
   
    Set oAxis = ActiveChart.Axes(xlValue)
   
    If IsMissing(hValue) Then
        oAxis.AxisTitle.Caption = Range("INFO_AXE_Y")
    Else
        If hValue = "" Then
            oAxis.AxisTitle.Caption = "-"
        Else
            oAxis.AxisTitle.Caption = hValue
        End If
    End If
   
    CHANGE_GRAPH_XL_VALUE = True
FIN:
    Set oGraphBarChart = Nothing
    Exit Function

HANDLE_ERROR:
    Resume FIN
End Function

Function CHANGE_GRAPH_XL_CATEGORY(Optional hGraph As String = "BAR_GRAPHIC", _
Optional hSourceWks As String = "PARAM_BAR", _
Optional hValue As Variant) As Boolean
 
    Dim oGraphBarChart As ChartObject
    Dim oAxis As Axis
   
    CHANGE_GRAPH_XL_CATEGORY = False
   
    On Error GoTo HANDLE_ERROR
   
    'Set oGraphBarChart = ActiveWorkbook.Worksheets(hSourceWks).ChartObjects(hGraph)
    Set oGraphBarChart = ActiveWorkbook.ActiveSheet.ChartObjects(hGraph)
    oGraphBarChart.Activate
   
    Set oAxis = ActiveChart.Axes(xlCategory)
    If IsMissing(hValue) Then
        oAxis.AxisTitle.Caption = Range("INFO_AXE_X")
    Else
        If hValue = "" Then
            oAxis.AxisTitle.Caption = "-"
        Else
            oAxis.AxisTitle.Caption = hValue
        End If
    End If
   
    CHANGE_GRAPH_XL_CATEGORY = True
   
FIN:
    Set oGraphBarChart = Nothing
    Exit Function

HANDLE_ERROR:
    Resume FIN
End Function


Sub INIT_MSG_PROGRESS_BAR()
    Range("MSG_TITRE") = ""
    Range("GRAPH_X_LIBELLE") = ""
    Range("INFO_AXE_Y") = ""
    Range("INFO_AXE_X") = ""
End Sub

Sub INIT_DEFAUT_MSG_PROGRESS_BAR()
    Range("MSG_TITRE") = "<DEFAUT>"
    Range("GRAPH_X_LIBELLE") = "<DEFAUT>"
    Range("INFO_AXE_Y") = "<DEFAUT>"
    Range("INFO_AXE_X") = "<DEFAUT>"
End Sub

Sub INIT_CHANGE_GRAPH_XL_VALUE_CATEGORY()
    Call CHANGE_GRAPH_XL_VALUE("BAR_GRAPHIC_2", , "")
    Call CHANGE_GRAPH_XL_CATEGORY("BAR_GRAPHIC_2", , "")
End Sub

Sub INIT_GRAPH_KPI_2_ZERO()
    Range("GRAPH_KPI") = 0
End Sub

Code complet concernant les shape

VB:

Option Explicit

Sub TEST_LOAD_SHAPE_PROGRESS_BAR()
    Call LOAD_SHAPE_PROGRESS_BAR("Feuil2", "E5")
End Sub

Sub TEST_UNLOAD_SHAPE_PROGRESS_BAR()
    Call UNLOAD_SHAPE_PROGRESS_BAR
End Sub

Sub TEST_SET_MSG_SHAPE_PROGRESS_BAR()
    Call SET_MSG_SHAPE_PROGRESS_BAR(, "Mon smh")
End Sub

Sub TEST_SHAPE_PROGRESS_10()
    Const MAX As Long = 500
    Dim oShape As Shape
    Dim iDx As Double
   
    Set oShape = LOAD_SHAPE_PROGRESS_BAR("Feuil2", "E10")
    If oShape Is Nothing Then
        MsgBox "Impossible de charger la barre de progression"
        Exit Sub
    End If
   
    SET_TRANSPARENCY_SHAPE_PROGRESS_BAR (1)
   
    For iDx = 0 To MAX
        Range("GRAPH_KPI") = iDx / MAX
        Call SET_MSG_SHAPE_PROGRESS_BAR(, "Traitement " & Format(iDx / MAX, "0%") & " effectué")
        Call SET_TRANSPARENCY_SHAPE_PROGRESS_BAR(1 - (iDx / MAX))
       
        ' Call SET_TRANSPARENCY_SHAPE_PROGRESS_BAR(Range("GRAPH_KPI"))
        DoEvents
    Next
    MsgBox "Fin"
    Set oShape = UNLOAD_SHAPE_PROGRESS_BAR()
    If oShape Is Nothing Then
        MsgBox "Impossible de supprimer la barre de progression"
        Exit Sub
    End If
   
End Sub

Sub TEST_SHAPE_PROGRESS_20()
    Const MAX As Long = 500
    Dim oShape As Shape
    Dim iDx As Double
   
    Set oShape = LOAD_SHAPE_PROGRESS_BAR("Feuil2", "E10")
    If oShape Is Nothing Then
        MsgBox "Impossible de charger la barre de progression"
        Exit Sub
    End If
   
    SET_TRANSPARENCY_SHAPE_PROGRESS_BAR (1)
   
    For iDx = 0 To MAX
        Range("GRAPH_KPI") = iDx / MAX
        Call SET_MSG_SHAPE_PROGRESS_BAR(, _
        "Traitement " & Format(iDx / MAX, "0%") & " effectué", _
        "Complément de message N° 1 : " & iDx, _
        "Complément de message N° 2 : étape de bouble " & iDx)
       
        Call SET_TRANSPARENCY_SHAPE_PROGRESS_BAR(1 - (iDx / MAX))
       
        ' Call SET_TRANSPARENCY_SHAPE_PROGRESS_BAR(Range("GRAPH_KPI"))
        DoEvents
    Next
    MsgBox "Fin"
    Set oShape = UNLOAD_SHAPE_PROGRESS_BAR()
    If oShape Is Nothing Then
        MsgBox "Impossible de supprimer la barre de progression"
        Exit Sub
    End If
   
End Sub

Function LOAD_SHAPE_PROGRESS_BAR(hDestWks As String, hAddress As String, _
Optional hShape As String = "SHAPE_PROGRESS_BAR_1", _
Optional hSourceWks As String = "PARAM_BAR") As Variant
     
    Dim oShape As Shape
   
    Set LOAD_SHAPE_PROGRESS_BAR = Nothing
   
   ' On Error GoTo HANDLE_ERROR

    Set oShape = ActiveWorkbook.Worksheets(hSourceWks).Shapes(hShape)
 
    oShape.Copy
   
    ActiveWorkbook.Worksheets(hDestWks).Activate
    Range(hAddress).Activate
    ActiveSheet.Paste

    Range("A1").Activate
   
    Set LOAD_SHAPE_PROGRESS_BAR = oShape
    Call SET_TRANSPARENCY_SHAPE_PROGRESS_BAR(1)

   
FIN:
    Set oShape = Nothing
    Exit Function

HANDLE_ERROR:
    Resume FIN
End Function

Function UNLOAD_SHAPE_PROGRESS_BAR(Optional hShape As String = "SHAPE_PROGRESS_BAR_1") As Variant
    Dim oShape As Shape

    Set UNLOAD_SHAPE_PROGRESS_BAR = Nothing
    Set oShape = ActiveSheet.Shapes(hShape)
    oShape.Delete
   
    Set UNLOAD_SHAPE_PROGRESS_BAR = oShape

FIN:
    Set oShape = Nothing
    Exit Function

HANDLE_ERROR:
    Resume FIN
End Function

Sub SET_MSG_SHAPE_PROGRESS_BAR(Optional hShape As String = "SHAPE_PROGRESS_BAR_1", _
Optional hMsg1 As String = "Traitement en cours", _
Optional hMsg2 As String = "", _
Optional hMsg3 As String = "")
    Dim oShape As Shape

    Set oShape = ActiveSheet.Shapes(hShape)
    oShape.TextFrame2.TextRange.Characters.Text = hMsg1 & vbLf & hMsg2 & vbLf & hMsg3
End Sub

Sub SET_TRANSPARENCY_SHAPE_PROGRESS_BAR(hValue As Double, _
Optional hShape As String = "SHAPE_PROGRESS_BAR_1")
    Dim oShape As Shape

    Set oShape = ActiveSheet.Shapes(hShape)
    oShape.Fill.Transparency = hValue
End Sub

Sub Macro2()
'
' Macro2 Macro
'

'

    ActiveSheet.Shapes.Range(Array("SHAPE_PROGRESS_BAR_1")).Select
    With Selection.ShapeRange.Fill
      '  .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
      '  .ForeColor.TintAndShade = 0
      '  .ForeColor.Brightness = 0
        .Transparency = 1
      '  .Solid
    End With

   
    'pour le texte
   
    ActiveSheet.Shapes.Range(Array("SHAPE_PROGRESS_BAR_1")).Select
    Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = _
        "xxxxxxx" & vbLf & "" & vbLf & ""
End Sub

Je vous laisse découvrir le fichier joint - pour vos tests en feuille 2 - il n'y a plus qu'à cliquer 🙂

Effectuez une recherche sur Excel Downloads...

EXCEL :: VBA :: Barre de progression via un graphique cylindrique, cubique, aquarium, donuts et shape

oguruma

XLDnaute Impliqué

Pièces jointes

Discussions similaires

Nous accordons de l'importance à votre vie privée