Discussion :

[popsmelove]

Bonjour,

j'utilise cette fonction pour remettre à l'échelle tous les graphiques d'un classeur. J'essaye d'optimiser le code mais je n'arrive pas en enlever les select, ça plante systhématiquement .

Si vous voyez ce que je peu faire, ou si vous avez mieux je suis preneur.

Merci d'avance

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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
Sub Graph_Scale_Update()
 
On Error GoTo msg
 
'Variables
Dim ValuesArray(), SeriesValues As Variant
Dim ValuesArrayY2(), SeriesValuesY2 As Variant
Dim minY, maxY, ecartY As Double
Dim minY2, maxY2, ecartY2 As Double
Dim i, j, z, w, Ctr, TotCtr As Integer
Dim zy2, Ctry2, TotCtry2 As Integer
Dim test, test2, testg As Boolean
Dim X As Series
Dim typeg As Integer
 
 
 
'Nombre de feuilles du classeur
 w = ActiveWorkbook.Sheets.Count
 
 For j = 1 To w
    'ActiveWorkbook.Sheets(j).Select
 
    'Comptage du nombre de graphiques de la feuille
    z = ActiveWorkbook.Sheets(j).ChartObjects.Count
 
    'Alerte si pas de graphique
    If z <> 0 Then
        ActiveWorkbook.Sheets(j).Select
        'bouclage des graphiques
        For i = 1 To z
            'Raz des variables graphiques
            testg = False
            'If (i = z And j = 4) Then testg = True
            test = False
            test2 = False
            SeriesValues = 0
            SeriesValuesY2 = 0
            TotCtr = 0
            TotCtry2 = 0
            Ctr = 0
            Ctry2 = 0
            ActiveSheet.ChartObjects(i).Select
 
            With ActiveSheet.ChartObjects(i).Chart
                If .ChartType = xlColumnClustered Then testg = True
                'Récupération des valeurs de la série
                For Each X In .SeriesCollection
                    If .HasAxis(xlValue, xlSecondary) = True Then
                        On Error Resume Next
                        If X.AxisGroup = 1 Then
                            SeriesValues = X.Values
                            If test = True Then
                                ReDim Preserve ValuesArray(1 To TotCtr + UBound(SeriesValues))
                            Else
                                ReDim ValuesArray(1 To TotCtr + UBound(SeriesValues))
                            End If
 
                            For Ctr = 1 To UBound(SeriesValues)
                                If IsError(SeriesValues(Ctr)) = False Then
                                    ValuesArray(Ctr + TotCtr) = SeriesValues(Ctr)
                                End If
                            Next
                            TotCtr = TotCtr + UBound(SeriesValues)
                            test = True
                        End If
                        If X.AxisGroup = 2 Then
                            SeriesValuesY2 = X.Values
                            If test2 = True Then
                                ReDim Preserve ValuesArrayY2(1 To TotCtr + UBound(SeriesValuesY2))
                            Else
                                ReDim ValuesArrayY2(1 To TotCtr + UBound(SeriesValuesY2))
                            End If
                            For Ctry2 = 1 To UBound(SeriesValuesY2)
                                If IsError(SeriesValuesY2(Ctry2)) = False Then
                                    ValuesArrayY2(Ctry2 + TotCtry2) = SeriesValuesY2(Ctry2)
                                End If
                            Next
                            TotCtry2 = TotCtry2 + UBound(SeriesValuesY2)
                            test2 = True
                        End If
                    Else
                        On Error Resume Next
                        SeriesValues = X.Values
                        If test = True Then
                            ReDim Preserve ValuesArray(1 To TotCtr + UBound(SeriesValues))
                        Else
                            ReDim ValuesArray(1 To TotCtr + UBound(SeriesValues))
                        End If
 
                        For Ctr = 1 To UBound(SeriesValues)
                            If IsError(SeriesValues(Ctr)) = False Then
                                ValuesArray(Ctr + TotCtr) = SeriesValues(Ctr)
                            End If
                        Next
                        TotCtr = TotCtr + UBound(SeriesValues)
                        test = True
                    End If
                 Next
 
                 'Calcul de l'écart mini maxi de la série
                 'mini = Application.Min(ValuesArray)
                 'maxi = Application.Max(ValuesArray)
                 'ecart = maxi - mini
                 'Détermination de la nouvelle valeur mini fonction de l'écart
                 minY = Application.Min(ValuesArray) - (Application.Max(ValuesArray) - Application.Min(ValuesArray)) / 10
                 maxY = Application.Max(ValuesArray) + (Application.Max(ValuesArray) - Application.Min(ValuesArray)) / 10
                 If .HasAxis(xlValue, xlSecondary) = True Then
                    minY2 = Application.Min(ValuesArrayY2) - (Application.Max(ValuesArrayY2) - Application.Min(ValuesArrayY2)) / 10
                    maxY2 = Application.Max(ValuesArrayY2) + (Application.Max(ValuesArrayY2) - Application.Min(ValuesArrayY2)) / 10
                 End If
                 '(mini Mod 10 ^ (Len(ecart) - 1))
                If .HasAxis(xlValue, xlSecondary) = True Then
                    .Axes(xlValue, xlPrimary).MinimumScale = minY
                    .Axes(xlValue, xlPrimary).MaximumScale = maxY
                    .Axes(xlValue, xlPrimary).MinorUnit = (maxY - minY) / 5
                    .Axes(xlValue, xlPrimary).MajorUnit = (maxY - minY) / 5
                    .Axes(xlValue, xlPrimary).CrossesAt = minY
 
                    .Axes(xlValue, xlSecondary).MinimumScale = minY2
                    .Axes(xlValue, xlSecondary).MaximumScale = maxY2
                    .Axes(xlValue, xlSecondary).MinorUnit = (maxY2 - minY2) / 5
                    .Axes(xlValue, xlSecondary).MajorUnit = (maxY2 - minY2) / 5
                    .Axes(xlValue, xlSecondary).CrossesAt = minY2
                Else
                    .Axes(xlValue, xlPrimary).MinimumScale = minY
                    .Axes(xlValue, xlPrimary).MaximumScale = maxY
                    .Axes(xlValue, xlPrimary).MinorUnit = (maxY - minY) / 5
                    .Axes(xlValue, xlPrimary).MajorUnit = (maxY - minY) / 5
                    If (testg Or .Name = "Graphique 30") Then
                        .Axes(xlValue, xlPrimary).CrossesAt = 0
                    Else
                        .Axes(xlValue, xlPrimary).CrossesAt = minY
                    End If
                End If
            End With
        Next i
    End If
Next j
Exit Sub
 
msg:
    MsgBox ("ERROR during Graph Scaling")
 
 
End Sub

[mercatog]

Bonjour

Je te propose de faire une procédure pour un graphique

Code :

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

1
2
3
4
5
6
Private Sub ChartScaleUpdate(ByVal Gr As ChartObject)
'partie declarations
 
With Gr.Chart
    TestG = .ChartType = xlColumnClustered
'.....

La variable Gr est un Chartobject (on ne sélectionne rien)

Ensuite une procédure finale où on boucle sur toutes les feuilles et tous les graphiques de chaque feuille sans rien sélectionner

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
Sub Finale()
Dim Ws As Worksheet
Dim Graphique As ChartObject
 
For Each Ws In ThisWorkbook.Worksheets
    For Each Graphique In Ws.ChartObjects
        Call ChartScaleUpdate(Graphique)
        'ou simplement
        'ChartScaleUpdate Graphique
    Next Graphique
Next Ws
End Sub

[popsmelove]

Merci Mercatog, je regarde cette solution qui m'a tout l'air d'être ce qu'il faut faire :o)

Ca marche au top,

Merci