Problème de ressource dans la gestion d'un graphique en VBA
Bonjour,
Je rencontre un problème dont je ne comprends pas l'origine.
Le classeur est un classeur xlsm.
La Feuille Interface contient un graphique et 2 groupes d'option (Formulaire) permettant de choisir la représentation des données en X et en Y.
Les données sont sur 4 feuilles (masquées):
La première feuille ne sert qu'à dessiner les limites.
Les 3 autres feuilles sont organisées de façon identique.
La mise à jour du graphique, en fonction des options sélectionnées, consiste juste à déplacer les plages de cellules source des série avec un offset, c'est-à-dire qu'il n'y a pas de calcul, juste 4 séries dont je modifie les adressses.
En vba, tous les objets publique sont déclarés et typés dans un module
Code:
1
2
3
4
| Public Graphique As Chart
Public Interface As Worksheet, Limites As Worksheet
Public wkValidés As Worksheet, wkNouveaux As Worksheet, wkRejetés As Worksheet, wkTotal As Worksheet 'Feuilles contenant les données
Public srValidés As SeriesCollection, srNouveaux As SeriesCollection, srRejetés As SeriesCollection 'Séries du Graphique |
Les objets sont initialisés à l'ouverture du classeur
Après clique sur une option, la fonction de mise à jour du graphique est appelée (dans la feuille Interface contenant les objets)
Code:
1
2
3
4
5
| Private Sub MiseAJourGraphique()
MiseAJourLimitesGraphique
MiseAJourSeriesGraphique
MiseEnRougeDesPoints
End Sub |
En fonction des options, les limites sont recalculées et mises à jours via des tableaux pour gagner du temps d'écriture (un calcul Worksheetfunction Min max, rien de terrible...)
Code:
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
| Private Sub MiseAJourLimitesGraphique()
Dim xMax As Range
If OptionSérie Then offsetX = 1 Else If OptionDate Then offsetX = 2 'Note Objet OptionButton de la feuille Interface
Set xMax = wkTotal.Range(wkTotal.Range("A2"), wkTotal.Range("A2").End(xlDown)).Offset(0, offsetX)
Limites.Range("B2") = WorksheetFunction.Min(xMax) - 1 'Note: Objet Worksheet Public
Limites.Range("B3") = WorksheetFunction.Max(xMax) + 1 'Note: Objet Worksheet Public
If OptionValeur Then 'Note: Objet OptionButton de la feuille Interface
offsetY = 3 'Note: variable Integer déclarée dans la Feuille Inteface
With Limites 'Note: Objet Worksheet Public
.Range("C2:C3") = Paramètre.Cible
.Range("D2:D3") = Paramètre.Cible - Paramètre.StdDev
.Range("E2:E3") = Paramètre.Cible - 2 * Paramètre.StdDev
.Range("F2:F3") = Paramètre.Cible - 3 * Paramètre.StdDev
.Range("G2:G3") = Paramètre.Cible + Paramètre.StdDev
.Range("H2:H3") = Paramètre.Cible + 2 * Paramètre.StdDev
.Range("I2:I3") = Paramètre.Cible + 3 * Paramètre.StdDev
End With
ElseIf OptionDS Then 'Note: Objet OptionButton de la feuille Interface
offsetY = 4
With Limites
.Range("C2:C3") = 0
.Range("D2:D3") = -1
.Range("E2:E3") = -2
.Range("F2:F3") = -3
.Range("G2:G3") = 1
.Range("H2:H3") = 2
.Range("I2:I3") = 3
End With
End If
End Sub |
La mise à jour des séries consiste à envoyer 3 paramètres textes à la fonction Mise à jour des séries
Les adresse des plages de cellules sont obtenues via des objets Range des objets publics WorkSheet et les variable du module (de la feuille) offsetX et offsetY.
Code:
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
| Private Sub MiseAJourSeriesGraphique()
Dim sr As Series, x$, y$
'Pour les 3 jeux de série, vérification présence de données. Si oui, mise à jour, sinon delete la série
With wkValidés
If Not IsEmpty(.Range("A2")) Then
x = "=" & .Name & "!" & .Range(.Range("A2"), .Range("A2").End(xlDown)).Offset(0, offsetX).Address
y = "=" & .Name & "!" & .Range(.Range("A2"), .Range("A2").End(xlDown)).Offset(0, offsetY).Address
CreationSerie "Validés", x, y
Else
On Error Resume Next
Graphique.SeriesCollection("Validés").Delete
On Error GoTo 0
End If
End With
With wkNouveaux
If Not IsEmpty(.Range("A2")) Then
x = "=" & .Name & "!" & .Range(.Range("A2"), .Range("A2").End(xlDown)).Offset(0, offsetX).Address
y = "=" & .Name & "!" & .Range(.Range("A2"), .Range("A2").End(xlDown)).Offset(0, offsetY).Address
CreationSerie "Nouveaux", x, y
Else
On Error Resume Next
Graphique.SeriesCollection("Nouveaux").Delete
On Error GoTo 0
End If
End With
With wkRejetés
If Not IsEmpty(.Range("A2")) Then
x = "=" & .Name & "!" & .Range(.Range("A2"), .Range("A2").End(xlDown)).Offset(0, offsetX).Address
y = "=" & .Name & "!" & .Range(.Range("A2"), .Range("A2").End(xlDown)).Offset(0, offsetY).Address
CreationSerie "Rejetés", x, y
Else
On Error Resume Next
Graphique.SeriesCollection("Rejetés").Delete
On Error GoTo 0
End If
End With
End Sub |
Enfin, la mise à jours
Code:
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
| Private Sub CreationSerie(Nom$, x$, y$)
Dim sr As Series
On Error Resume Next
Set sr = Graphique.SeriesCollection(Nom)
On Error GoTo 0
If sr Is Nothing Then
Set sr = Graphique.SeriesCollection.NewSeries
With sr
.Name = Nom
.ChartType = xlXYScatter
.XValues = x
.Values = y
Select Case Nom
Case "Validés"
.MarkerStyle = xlMarkerStyleCircle
.MarkerBackgroundColor = vbGreen
.MarkerForegroundColor = vbGreen
Case "Rejetés"
.MarkerStyle = xlMarkerStyleX
.MarkerForegroundColor = vbRed
Case "Nouveaux"
.MarkerStyle = xlMarkerStyleCircle
.MarkerBackgroundColor = vbBlue
.MarkerForegroundColor = vbBlue
End Select
End With
Else
sr.XValues = x
sr.Values = y
End If
End Sub |
Voila...
Tout semble propre.
Il y a peu de ligne.
Ça devrait tourner sans problème mais non!
Ça prends plus plusieurs minutes avec la roue qui s'affiche et Excel qui ne répond plus temporairement.
Au bout de quelque clics. Excel plante définitivement. C'est à n'y rien comprendre.
Une idée ???
