Graphe bâton avec plusieurs séries

**hobine** · 28/11/2011, 22h40

Bonjour,
Je souhaite programmer en vba la génération d'un graphe bâton. J'ai plusieurs séries (3) à traces sur un même graph.
J'ai écrit ceci, mais cela ne fonctionne pas. J'ai vérifier que les valeurs des tableaux PossDirection , tabDir1 , tabDir2 et tabDir3 sont correctes

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
    Charts.Add
     With ActiveChart
 
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tabDir1 'Ordonnées
       ' .SeriesCollection.NewSeries
        .SeriesCollection(1).Values = tabDir2 'Ordonnées
       ' .SeriesCollection.NewSeries
        .SeriesCollection(1).Values = tabDir3 'Ordonnées
        .ChartType = xlColumnClustered   'type de graph
        .HasTitle = True
        .ChartTitle.Characters.Text = "xxx"
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = ""
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Nombre de mutations"
    End With

Merci pour votre aide

**mercatog** · 28/11/2011, 22h51

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
Dim Ch As Chart
Dim Sr As Series
 
Set Ch = Charts.Add
With Ch
    .ChartType = xlColumnClustered               'type de graph
    .HasTitle = True
    .ChartTitle.Characters.Text = "xxx"
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = ""
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Nombre de mutations"
    Set Sr = .SeriesCollection.NewSeries
    Sr.XValues = PossDirection                   'Abscisses
    Sr.Values = tabDir1                          'Ordonnées
    Set Sr = Nothing
    .SeriesCollection.NewSeries.Values = tabDir2    'Ordonnées
    .SeriesCollection.NewSeries.Values = tabDir3    'Ordonnées
End With

**hobine** · 28/11/2011, 23h02

La variable PossDirection contient des chaînes de caractère mais lorsque j'exécute votre programme, j'obtiens en abscisse 1,2,3,4. D'autre part j'ai une série en trop (4 séries dans la légende alors que je n'en programme que 3) et le format des ordonnées est fantaisiste (janv-00)

Cordialement

**mercatog** · 28/11/2011, 23h07

J'ai fais des tests sans problème, reporte ici ton code en entier (notamment comment sont remplis tes tableaux)

**hobine** · 28/11/2011, 23h10

tu trouveras ci dessous le code entier.
Cordialement

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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
Sub CreateChartChoixMultiple(feuille As String)
    Dim Plage As Range
    Dim PossDirection() As Variant, PossPeriode() As Variant, PossMetier() As Variant
    Dim SPossPeriode() As Variant
    Dim listeDirection() As Variant, listeMetier() As Variant
    Dim i As Integer, j As Integer, nl As Integer, nligne As Integer
    Dim myrange As String, mysheetname As String
    Dim shtoto As Worksheet
    Dim tmp() As Variant
    Dim d As Double
    Dim c As Range
    Dim test() As String
    Dim tableau2() As Double
    Dim Dir1() As Variant, Dir2() As Variant, Dir3() As Variant
    Dim listeDir1() As Variant, listeDir2() As Variant, listeDir3() As Variant
    Dim n1 As Integer
    Dim n2 As Integer
    Dim n3 As Integer
 
    Worksheets(feuille).Activate
 
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("AP8:AP" & Range("AP65536").End(xlUp).Row)
    PossPeriode = Application.Transpose(Plage.Value)
    PossPeriode = sans_vide(PossPeriode)
    listePeriode = PossPeriode
    PossPeriode = SupprimerDoublons(PossPeriode)
    SPossPeriode = range_croissant(PossPeriode)
    For i = 1 To UBound(PossPeriode)
        PossPeriode(i) = SPossPeriode(i)
    Next i
 
 
    ' récupération des directions pour le scénario1
    Set Plage = Range("AQ8:AQ" & Range("AQ65536").End(xlUp).Row)
    Dir1 = Application.Transpose(Plage.Value)
    Dir1 = sans_vide(Dir1)
    listeDir1 = Dir1
    Dir1 = SupprimerDoublons(Dir1)
 
   ' récupération des directions pour le scénario2
    Set Plage = Range("AW8:AW" & Range("AW65536").End(xlUp).Row)
    Dir2 = Application.Transpose(Plage.Value)
    Dir2 = sans_vide(Dir2)
    listeDir2 = Dir2
    Dir2 = SupprimerDoublons(Dir2)
 
' récupération des directions pour le scénario3
    Set Plage = Range("BC8:BC" & Range("BC65536").End(xlUp).Row)
    Dir3 = Application.Transpose(Plage.Value)
    Dir3 = sans_vide(Dir3)
    listeDir3 = Dir3
    Dir3 = SupprimerDoublons(Dir3)
 
 
    ' récupération de la valeur de la première année
 
    possannee1 = premiere_annee(PossPeriode)
 
    annee1 = Split(possannee1(1), "-")
 
    ncount = 0
    For i = 1 To UBound(listePeriode)
        For j = 1 To UBound(possannee1)
            If listePeriode(i) = possannee1(j) Then
                ncount = ncount + 1
            End If
        Next j
    Next i
 
 
    icount = 0
    ReDim PossDirection(1 To (3 * ncount))
    For i = 1 To UBound(listePeriode)
        For j = 1 To UBound(possannee1)
            If listePeriode(i) = possannee1(j) Then
                PossDirection(icount + 1) = listeDir1(i)
                PossDirection(icount + 2) = listeDir2(i)
                PossDirection(icount + 3) = listeDir3(i)
                icount = icount + 3
            End If
        Next j
    Next i
    PossDirection = SupprimerDoublons(PossDirection)
 
 
 
 
 
 
    ReDim dir1annee1(1 To ncount)
    ReDim dir2annee1(1 To ncount)
    ReDim dir3annee1(1 To ncount)
    ncount = 0
    For i = 1 To UBound(listePeriode)
        For j = 1 To UBound(possannee1)
            If listePeriode(i) = possannee1(j) Then
                ncount = ncount + 1
                dir1annee1(ncount) = listeDir1(i)
                dir2annee1(ncount) = listeDir2(i)
                dir3annee1(ncount) = listeDir3(i)
            End If
        Next j
    Next i
 
 
 
   ReDim tabDir1(1 To UBound(PossDirection))
   ReDim tabDir2(1 To UBound(PossDirection))
   ReDim tabDir3(1 To UBound(PossDirection))
   For i = 1 To UBound(dir1annee1)
    For j = 1 To UBound(PossDirection)
        If dir1annee1(i) = PossDirection(j) Then
            tabDir1(j) = tabDir1(j) + 1
        End If
        If dir2annee1(i) = PossDirection(j) Then
            tabDir2(j) = tabDir2(j) + 1
        End If
        If dir3annee1(i) = PossDirection(j) Then
            tabDir3(j) = tabDir3(j) + 1
        End If
 
    Next j
    Next i
 
 
 
 
 
    Charts.Add
     With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tabDir1   'Ordonnées
       ' .SeriesCollection.NewSeries
        .SeriesCollection(1).Values = tabDir2 'Ordonnées
       ' .SeriesCollection.NewSeries
        .SeriesCollection(1).Values = tabDir3 'Ordonnées
        .ChartType = xlColumnClustered   'type de graph
        .HasTitle = True
        .ChartTitle.Characters.Text = "xxx"
        .Axes(xlCategory, xlPrimary).HasTitle = True
        .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = ""
        .Axes(xlValue, xlPrimary).HasTitle = True
        .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Nombre de mutations"
    End With
    ActiveChart.HasLegend = False
   Dim Ch As Chart
Dim Sr As Series
 
Set Ch = Charts.Add
With Ch
    .ChartType = xlColumnClustered               'type de graph
    .HasTitle = True
    .ChartTitle.Characters.Text = "xxx"
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = ""
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Nombre de mutations"
    Set Sr = .SeriesCollection.NewSeries
    Sr.XValues = PossDirection                   'Abscisses
    Sr.Values = tabDir1                          'Ordonnées
    Set Sr = Nothing
    .SeriesCollection.NewSeries.Values = tabDir2    'Ordonnées
    .SeriesCollection.NewSeries.Values = tabDir3    'Ordonnées
End With
 
End Sub
 
 
Function SupprimerDoublons(tbl()) As Variant()
 
    Dim Dico As Object
    Dim Cle
    Dim T()
    Dim i As Long
 
    'crée l'objet
 
    Set Dico = CreateObject("Scripting.Dictionary")
 
    'inscrit les valeurs dans le dictionnaire
    'en affectant aussi cette valeur à la clé
    'une clé devant être unique, si on ne contrôle pas
    'son existance dans la collection, un erreur est générée
    For i = 1 To UBound(tbl)
        If Dico.Exists(tbl(i)) = False Then
            Dico.Add tbl(i), tbl(i)
        End If
    Next i
 
    i = 0
 
    'tranfert des valeurs uniques dans un tableau
    For Each Cle In Dico.keys
        i = i + 1
        ReDim Preserve T(1 To i)
        T(i) = Cle
    Next
 
 
 
 
    'passage de ce tableau à la fonction
    SupprimerDoublons = T
 
    'libère la mémoire
    Set Dico = Nothing
 
End Function
 
 
 Function WsExist(nomFeuil As String) As Boolean
On Error Resume Next
WsExist = Sheets(nomFeuil).Index
   End Function
 
 
 
 
Function sans_zero(tbl()) As Variant()
    Dim ih As Integer
    Dim nn As Integer
    Dim i As Integer
    Dim T()
 
 
 
        ih = 0
        For i = 1 To UBound(tbl)
            If tbl(i) <> 0 Or tbl(i) <> " " Or tbl(i) <> "0" Then
                ih = ih + 1
            End If
        Next i
    ReDim T(ih)
        nn = 0
        For i = 1 To UBound(tbl)
            If tbl(i) <> 0 Or tbl(i) <> " " Or tbl(i) <> "0" Then
                nn = nn + 1
                T(nn) = tbl(i)
            End If
        Next i
 
    sans_zero = T
 
 
End Function
 
 
 Function range_croissant(tbl()) As Variant()
    Dim tmp() As Variant
    Dim tmp1() As String
    Dim tmp2() As String
 
    Dim trim() As String
    Dim annee() As String
    Dim min_an As Integer
    Dim max_an As Integer
    Dim annees() As String
    Dim ndim As Integer
    Dim trimestre2D() As Integer
 
 
    ndim = UBound(tbl)
 
 
    ReDim trim(ndim)
    ReDim annee(ndim)
    For i = 1 To ndim
        tmp1 = Split(tbl(i), "-")
        tmp2 = Split(tmp1(0), "T")
        trim(i) = tmp2(1)
        annee(i) = tmp1(1)
    Next i
 
    min_an = min_annee(tbl)
    max_an = max_annee(tbl)
 
    ReDim trimestre2D(max_an - min_an + 1, 4)
    For i = 1 To (max_an - min_an + 1)
        For j = 1 To 4
            trimestre2D(i, j) = 0
        Next j
    Next i
    For k = 1 To ndim
        For j = 1 To 4
            If Val(trim(k)) = j Then
                it = j
            End If
        Next j
        For i = min_an To max_an
            If Val(annee(k)) = i Then
                ia = i - min_an + 1
            End If
        Next i
 
        trimestre2D(ia, it) = k
    Next k
 
   ReDim tmp(1 To UBound(tbl))
   ncount = 0
   For i = 1 To (max_an - min_an + 1)
        For j = 1 To 4
            If trimestre2D(i, j) <> 0 Then
                ncount = ncount + 1
                k = trimestre2D(i, j)
                tmp(ncount) = "T" & trim(k) & "-" & annee(k)
            End If
        Next j
    Next i
 
 
 
   range_croissant = tmp
   End Function
 
Function min_annee(tbl()) As Integer
    Dim imin As Integer
    Dim tmp1() As String
    Dim annee() As String
 
    ndim = UBound(tbl)
    ReDim annee(ndim)
    For i = 1 To ndim
        tmp1 = Split(tbl(i), "-")
        annee(i) = tmp1(1)
    Next i
 
    imin = annee(1)
 
    For i = 2 To UBound(annee)
        If Val(annee(i)) < imin Then
            imin = Val(annee(i))
        End If
    Next i
min_annee = imin
 
End Function
Function max_annee(tbl()) As Integer
    Dim imax As Integer
    Dim tmp1() As String
    Dim annee() As String
 
    ndim = UBound(tbl)
    ReDim annee(ndim)
    For i = 1 To ndim
        tmp1 = Split(tbl(i), "-")
        annee(i) = tmp1(1)
    Next i
 
    imax = annee(1)
 
    For i = 2 To UBound(annee)
        If Val(annee(i)) > imax Then
            imax = Val(annee(i))
        End If
    Next i
max_annee = imax
 
End Function
 
 
 
Function premiere_annee(tbl()) As Variant
    Dim tmp() As Variant
    Dim annee1 As Integer
    Dim tmp1() As String
    Dim ndim As Integer
 
 
    ndim = UBound(tbl)
 
    annee1 = min_annee(tbl)
 
    ReDim tmp(ndim)
 
    For i = 1 To ndim
     tmp1 = Split(tbl(i), "-")
     If Val(tmp1(1)) = annee1 Then
        tmp(i) = tbl(i)
     End If
    Next i
 
    tmp = sans_zero(tmp)
 
 
premiere_annee = tmp
End Function
 
 
 
 
Function sans_vide(tbl()) As Variant()
    Dim ih As Integer
    Dim nn As Integer
    Dim i As Integer
    Dim T()
    Dim test() As Variant
 
 
    ReDim test(UBound(tbl))
    For i = 1 To UBound(tbl)
        test(i) = trim(tbl(i)) & "vide"
    Next i
        ih = 0
        For i = 1 To UBound(tbl)
            If test(i) <> "vide" Then
                ih = ih + 1
            End If
        Next i
    ReDim T(ih)
        nn = 0
        For i = 1 To UBound(tbl)
            If test(i) <> "vide" Then
                nn = nn + 1
                T(nn) = tbl(i)
            End If
        Next i
 
    ReDim sans_vide(ih)
 
    sans_vide = T
 
End Function

**mercatog** · 28/11/2011, 23h16

Que font les lignes de 131 à 148?

**hobine** · 29/11/2011, 09h44

de la ligne 131 à 148 est supposé générer un graphe en bâton pour une période x (possperiode) qu'elle puisse donner les directions respectives du choix 1, du choix 2 et du choix 3, ainsi de suite jusqu' à n période.

Malheureusement, elle ne fait que pour 2 cas (par exple ceux du choix 1 et 2) mais par les 3 comme voulu

Cordialement

**mercatog** · 29/11/2011, 11h20

Et si tu remplaces les lignes en question par la proposition que je t'avais proposée en "2

**hobine** · 29/11/2011, 13h43

C'est exactement ce que j'ai fait mais cela affiche un résultat différent de ce que je veux.
déjà au niveau de l'axe des abscisses
- ça m'affiche les 1, 2, 3,4 . Non seulement ma table possdirection contient des chaines de caractères (exple. DIV, DCT...) qui doivent aussi s'affichent pour permettre à l'utilisateur de voir de quelle direction il s'agit.
- ça m'affiche 4 séries i.e. alors que j'ai uniquement 3 series (tabDir1, tabDir2, tabDir3)

sur l'axe des ordonnées au lieu d'afficher le chiffre (le nombre de fois qu'une direction est prise en compte), ça m'affiche plutôt jan-00 à tous le niveaux.

Cordialement

Bonsoir Mercatog,
je te mets un exple de mon fichier en PJ pour que tu puisses s'il te plaît corriger les fautes de mon programme.
Merci d'avance

**mercatog** · 29/11/2011, 14h42

Tu peux expliquer ce que tu veux faire?

**hobine** · 29/11/2011, 21h38

faire un graphe en bâton et en camembert qui regroupe les directions du choix 1 du scénario 1, scénario 2 et scénario 3 de l'année la plus proche ( dans notre cas par exple, l'année 2012 est la plus proche)

L'axe des abscisses comportera toutes les directions possibles de chaque scénario. le nom de ces directions apparaîtront sur l'axe.
l'axe des ordonnées comporte le nombre de fois qu’apparaît une direction.
nous aurons enfin de compte trois séries. c'est pour ce qui est du graphe bâton

Pour le graphe camembert, cela sera plutôt une représentation par pourcentage des directions apparues dans les scénarios (ici, on fait la somme des directions, peu importe le choix)

Cordialement

En modifiant un peu l'ordre du code, on finit par obtenir le graph voulu

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
Set Ch = Charts.Add
With Ch
    Call RemoveUnwantedSeries
    Set Sr = .SeriesCollection.NewSeries
    Sr.XValues = PossDirection                   'Abscisses
    Sr.Values = tabDir1                          'Ordonnées
    Sr.Name = "Scénario 1"
    Set Sr = Nothing
    .SeriesCollection.NewSeries.Values = tabDir2    'Ordonnées
    .SeriesCollection.NewSeries.Values = tabDir3    'Ordonnées
    .ChartType = xlColumnClustered               'type de graph
    .HasTitle = True
    .ChartTitle.Characters.Text = "xxx"
    .Axes(xlCategory, xlPrimary).HasTitle = True
    .Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = ""
    .Axes(xlValue, xlPrimary).HasTitle = True
    .Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Nombre de mutations"
 
End With

J'arrive à renommer la Série 1, par contre je ne vois pas comment faire pour les deux autres séries

**mercatog** · 29/11/2011, 22h18

Code :

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

1
2
3
4
With .SeriesCollection.NewSeries
    .Values = tabDir2
    .Name = "Scénario 2"
End With

**hobine** · 30/11/2011, 09h21

Bonjour ,
Merci beaucoup pour ton Aide

Cordialement

Graphe bâton avec plusieurs séries

Macros et VBA Excel

Discussions similaires

Partager

Partager