Bonjour,

j'ai l'habitude d'utiliser le code vba suivant pour redimensionner les échelles de tous les graphiques d'un classeur Excel.

Malheureusement le code ne marche pas quand il s'agit d'une feuille graphique (quand l'emplacement du graphique est une nouvelle feuille)...? en effet quand on cherche a extraire les values des séries, le code nous renvoi du vide alors qu'il marche très bien pour un graphique contenu dans une feuille lambda.

Quelqu'un a t-il une idée de ce qui ne va pas dans mon code ?

Merci

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
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 z, w, Ctr, TotCtr As Integer
Dim zy2, Ctry2, TotCtry2 As Integer
Dim test, test2, testg As Boolean
 
'Comptage du 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 = ActiveSheet.ChartObjects.Count
 
    'Alerte si pas de graphique
    If z <> 0 Then
        'bouclage des graphiques
        For i = 1 To z
            'Raz des variables graphiques
            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
                '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
                    .Axes(xlValue, xlPrimary).CrossesAt = minY
                    End If
                End If
            End With
        Next i
    End If
Next j
Exit Sub
 
msg:
    MsgBox ("ERROR")
 
 
End Sub