Allègement Code VBA Graphique

**askorps** · 29/07/2020, 21h57

Bonsoir à tous,

J'ai réalisé un petit code permettant de mettre en forme une série de données sous la forme d'un graphique.

La particularité de ce graphique et de colorer les points le composant dès que ceux-ci dépassent une certaine valeur (par exemple, si valeur < seuil 25 : couleur bleu ; si > 25 : couleur rouge).

Quand j'ai fait les tests sur une petite base de donnée (environ 2500 lignes), le code fonctionnait sans problème. En revanche sur des bases de données plus grandes (environ 50 000 lignes), le code plante à la mise en forme finale ...

Ainsi, auriez-vous une solution pour réaliser la même tâche mais "allegée" ?

Pour essayer de faciliter la comprehension, le code est décomposée en 3 étape :

La première, effectue quelques calculs qui me seront utiles pour d'autres macros; et définit également le "seuil" de changement de couleur

La deuxième étape, créer un graphique "basique", en vu de la mise en forme

La 3ème étape change la couleur des points du graphique supérieur à la valeur seuil. Pour cela je réalise une boucle sur chaque point.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
Sub MAV()
 
Dim MAV As Double
 
Cells(1, 11).Value = "Marche pleine"
Cells(1, 12).Value = "Marche a vide"
Cells(1, 13).Value = "Seuil MAV/MP déterminé"
Columns("L:L").AutoFit
Cells(1, 14).Value = InputBox("Choix intensité seuil bascule MP/MAV ?")
Cells(1, 14).NumberFormat = "0.00" & " A"
MAV = Cells(1, 14)
'Temps de MAV
 
nb_rows = Cells(Cells.Rows.Count, 1).End(xlUp).Row 'Compter le nb de ligne de la feuille
 
For i = 2 To nb_rows
 
If Cells(i, 9) >= MAV Then
    Cells(i, 12).Value = Cells(i, 9)
    Cells(1, 12).NumberFormat = "0.00"
 
ElseIf Cells(i, 9) < MAV Then
    Cells(i, 11).Value = Cells(i, 9)
    Cells(1, 11).NumberFormat = "0.00"
 
End If
 
Next
 
'CREA GRAPHIQUE
 
nb_rows = Cells(Cells.Rows.Count, 1).End(xlUp).Row
MiniOrdo = WorksheetFunction.Min(Range(Cells(1, 9), Cells(nb_rows, 9)))
MaxiOrdo = WorksheetFunction.Max(Range(Cells(2, 9), Cells(nb_rows, 9))) + 5
    Application.ScreenUpdating = False
 
    Union(Range(Cells(1, 1), Cells(nb_rows, 1)), Range(Cells(1, 9), Cells(nb_rows, 9))).Select
    Set Graphique = ActiveSheet.Shapes.AddChart2(240, xlXYScatterLinesNoMarkers)
 
    Graphique.Chart.ChartTitle.Text = "Détail MAV et PM " & Cells(1, 9)
    Graphique.Chart.ChartTitle.Font.Name = "Tahoma"
    Graphique.Chart.ChartTitle.Font.Bold = True
 
    Graphique.Chart.Axes(xlCategory).HasTitle = True 'titre
    Graphique.Chart.Axes(xlCategory).AxisTitle.Text = "Période de mesure" 'nom titre
    Graphique.Chart.Axes(xlCategory).TickLabels.Font.Name = "Tahoma" 'police axe
    Graphique.Chart.Axes(xlCategory).TickLabels.Font.Size = 7 'taille police axe
    Graphique.Chart.Axes(xlCategory).AxisTitle.Font.Name = "Tahoma" 'police titre
    Graphique.Chart.Axes(xlCategory).TickLabels.NumberFormat = "dd/mm - hh:mm"
    Graphique.Chart.Axes(xlCategory).AxisTitle.Font.Bold = True 'gras titre
    Graphique.Chart.Axes(xlCategory).MinimumScale = Cells(2, 1)
    Graphique.Chart.Axes(xlCategory).MaximumScale = Cells(nb_rows, 1)
 
    Graphique.Chart.Axes(xlValue).HasTitle = True
    Graphique.Chart.Axes(xlValue).AxisTitle.Text = "Intensité(A)"
    Graphique.Chart.Axes(xlValue).AxisTitle.Font.Bold = True
    Graphique.Chart.Axes(xlValue).TickLabels.Font.Name = "Tahoma" 'police axe
    Graphique.Chart.Axes(xlValue).TickLabels.Font.Size = 7 'taille police axe
    Graphique.Chart.Axes(xlValue).MinimumScale = MiniOrdo
    Graphique.Chart.Axes(xlValue).MaximumScale = MaxiOrdo
    Graphique.Chart.Axes(xlValue).TickLabels.NumberFormat = 0
 
    Graphique.Chart.ChartArea.Width = 510
    Graphique.Chart.ChartArea.Height = 226
 
    Graphique.Fill.Visible = msoFalse
 
' MISE EN FORME COULEUR SEUIL
 
With Graphique.Chart.SeriesCollection(1)
For i = 1 To .Points.Count
Pts = .Values
If Pts(i) < MAV Then
    .Points(i).Format.Line.ForeColor.RGB = RGB(26, 127, 193)
Else
    .Points(i).Format.Line.ForeColor.RGB = RGB(193, 26, 61)
 
End If
 
Next
End With
 
    Graphique.Chart.FullSeriesCollection(1).Format.Line.Weight = 0.25
    Graphique.Chart.FullSeriesCollection(1).Format.Shadow.Type = msoShadow22
 
End Sub

Je ne peux joindre le fichier qui est trop lourd. Je pourrais en revanche le transmettre par wetransfer si besoin

En vous remerciant !

**marot_r** · 29/07/2020, 22h29

Bonjour.

Je ne répond pas directement à ta question mais j'ai trouvé cela qui pourrait peut-être une solution plus légère.

Conditional Formatting in column (bar) charts
https://excel-example.com/charts/con...umn-bar-charts

Ou cela :
Conditional Formatting of Excel Charts
https://peltiertech.com/conditional-...-excel-charts/
Qui traite de plus que les histogrammes.

A+

**askorps** · 30/07/2020, 08h50

Bonjour, merci !

c'ets déjà une piste à creuser, je vais regarder ça,

**askorps** · 30/07/2020, 09h15

Effectivement, j'ai modifié l'approche :

Au lieu de changer la couleur de chaque points, j'ai créé une seconde courbe qui vient se superposer à la première. Les données de la courbe sont créées à partir d'une colonne qui ne comptabilise que les valeurs supérieures au seuil :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
nb_rows = Cells(Cells.Rows.Count, 1).End(xlUp).Row 'Compter le nb de ligne de la feuille
 
For i = 2 To nb_rows
 
If Cells(i, 9) >= MAV Then
    Cells(i, 12).Value = Cells(i, 9)
    Cells(1, 12).NumberFormat = "0.00"
 
ElseIf Cells(i, 9) < MAV Then
    Cells(i, 11).Value = Cells(i, 9)
    Cells(1, 11).NumberFormat = "0.00"
 
End If
 
Next

Il suffit ensuite de rajouter une seconde courbe, basée sur la nouvelle colonne précedemment créée, et de mettre une couleur différente :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
Union(Range(Cells(1, 1), Cells(nb_rows, 1)), Range(Cells(1, 9), Cells(nb_rows, 9)), Range(Cells(1, 12), Cells(nb_rows, 12))).Select
Graphique.Chart.FullSeriesCollection(2).Format.Line.ForeColor.RGB = RGB(193, 26, 61)
    Graphique.Chart.FullSeriesCollection(2).Format.Line.Weight = 0.25
    Graphique.Chart.FullSeriesCollection(2).Format.Shadow.Type = msoShadow22

Merci, bonne journée

Allègement Code VBA Graphique

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager