[XL-2003] un graphe du .ChartType = xlColumnStacked

un graphe du .ChartType = xlColumnStacked

Bonjour,
j'aimerai mettre ces données sur un histogramme empilé mais je ne connais pas comment faire.
Vous trouverez ci-dessous un bout de mon programme.
L'axe des abscisses est possperiode et sur chaque période associe par un code couleur le nombre de fois qu'un métier apparaît. une légende indiquant à quelle couleur correspond tel métier.
merci par avance

j'ai pu avancer sans vraiment avancer.
il y a bug sur mon code et j'y arrive pas. Un âme sensible peut il s'il vous plaît me delivrer de toutes ces souffrances?

La faute se trouve à la ligne 198. ( je veux faire un graphe en histogramme empilé)

merci par avance

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
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
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
Sub CreateChartToutesAnnees(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
    Dim Ch As Chart
    Dim Sr As Series
    Dim today As String
    Dim possMetierDCT() As Variant
    Dim countMetierDCT() As Integer
    Dim listeMetier1() As Variant
    Dim listeMetier2() As Variant
    Dim listeMetier3() As Variant
    Dim metierActuel() As Variant
    Dim PossMetierActuel() As Variant
    Dim MonGraphe As Chart
    Dim MaPlage As Range
    Dim MaZone As Range
 
    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 des métiers actuel
    Set Plage = Range("L8:L" & Range("L65536").End(xlUp).Row)
    metierActuel = Application.Transpose(Plage.Value)
    metierActuel = sans_vide(metierActuel)
    PossMetierActuel = SupprimerDoublons(metierActuel)
 
    MsgBox UBound(PossMetierActuel)
    MsgBox UBound(metierActuel)
 
 
 
    ncount = UBound(listeDir2)
' on determine les directions possibles
    icount = 0
    ReDim PossDirection(1 To (3 * ncount))
    For i = 1 To ncount
                PossDirection(icount + 1) = listeDir1(i)
                PossDirection(icount + 2) = listeDir2(i)
                PossDirection(icount + 3) = listeDir3(i)
                icount = icount + 3
    Next i
    PossDirection = SupprimerDoublons(PossDirection)
 
 
 
   ReDim tabtotal(1 To UBound(PossDirection))
   For i = 1 To ncount
        For j = 1 To UBound(PossDirection)
        If listeDir1(i) = PossDirection(j) Then
            tabtotal(j) = tabtotal(j) + 1
        End If
        If listeDir2(i) = PossDirection(j) Then
            tabtotal(j) = tabtotal(j) + 1
        End If
        If listeDir3(i) = PossDirection(j) Then
            tabtotal(j) = tabtotal(j) + 1
        End If
        Next j
    Next i
 
 
 
 
 
 
 
Charts.Add
With ActiveChart
    Call RemoveUnwantedSeries
    .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
      .SeriesCollection(1).Values = tabtotal 'Ordonnées
        .ChartType = xlPie
        .SeriesCollection(1).ApplyDataLabels AutoText:=True, LegendKey:= _
            False, HasLeaderLines:=True, ShowSeriesName:=False, ShowCategoryName:= _
            True, ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False, Separator _
        :="" & Chr(10) & ""
        .HasLegend = False
        With .SeriesCollection(1).DataLabels
           .HorizontalAlignment = xlCenter
           .VerticalAlignment = xlCenter
           .ReadingOrder = xlContext
           .Position = xlLabelPositionCenter
           .Orientation = xlHorizontal
        End With
       With .SeriesCollection(1)
          p = .Values
          For i = 1 To .Points.Count
              If p(i) = 0 Then .Points(i).DataLabel.Delete
          Next
End With
        .HasTitle = True
        .ChartTitle.Characters.Text = "quelques soient les postes quellesque soient les années"
 
End With
 
 
 
' tableau à deux entrées en ligne les périodes, en colonne les métiers
 
 
 
 ' récupération des directions pour le scénario1
 
    nlignes = UBound(PossPeriode)
    ncolones = UBound(PossMetierActuel)
    ReDim tableau(1 To nlignes, 1 To ncolones)
    For i = 1 To UBound(metierActuel)
        For j = 1 To nlignes
            If listeperiode(i) = PossPeriode(j) Then
                For k = 1 To ncolones
                    If metierActuel(i) = PossMetierActuel(k) Then
                        tableau(j, k) = tableau(j, k) + 1
                    End If
                Next k
            End If
        Next j
 
 
    Next i
 
 
    Worksheets("Feuil1").Activate
 
    For i = 1 To UBound(PossMetierActuel)
        Cells(100, i + 1) = PossMetierActuel(i)
    Next i
    For i = 1 To UBound(PossPeriode)
        Cells(100 + i, 1) = PossPeriode(i)
    Next i
    For i = 1 To UBound(PossMetierActuel)
        For j = 1 To UBound(PossPeriode)
            Cells(100 + j, i + 1) = tableau(j, i)
         Next j
 
    Next i
 
 
 
 
 
   ' Charts.Add
    Call RemoveUnwantedSeries
 
Set MaZone = Worksheets("Feuil1").Range(Cells(100, 1), Cells(100 + nlignes, 1 + ncolones))
Charts.Add
ActiveChart.ChartType = xlColumnStacked
ActiveChart.SetSourceData Source:=MaZone, PlotBy:=xlRows
 
 
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
 
Sub RemoveUnwantedSeries()
With ActiveChart
    Do Until .SeriesCollection.Count = 0
        .SeriesCollection(1).Delete
    Loop
End With
End Sub
 
 
Function prochaine_annee(today) As Variant
    Dim tmp(1 To 4) As Variant
    Dim num_trimestre(1 To 4) As Integer
    Dim ian(1 To 4) As Integer
    Dim a() As String
    Dim mois As String, annee As String
    Dim trimestre As Integer
 
 
    a = Split(today, "/")
    mois = a(1)
    b = Split(a(2), " ")
    annee = b(0)
    If mois < 4 Then
        trimestre = 1
    ElseIf mois < 7 Then
        trimestre = 2
    ElseIf mois < 10 Then
        trimestre = 3
    Else
        trimestre = 4
    End If
 
 
 
    If trimestre <> 4 Then
        num_trimestre(1) = trimestre + 1
        ian(1) = Int(annee)
    Else
        num_trimestre(1) = 1
        ian(1) = Int(annee) + 1
    End If
    tmp(1) = "T" & Str(num_trimestre(1)) & "-" & ian(1)
 
 
    For i = 2 To 4
        If num_trimestre(i - 1) <> 4 Then
            num_trimestre(i) = num_trimestre(i - 1) + 1
            ian(i) = ian(i - 1)
        Else
            num_trimestre(i) = 1
            ian(i) = ian(i - 1) + 1
        End If
        tmp(i) = "T" & Str(num_trimestre(i)) & "-" & ian(i)
    Next i
 
    For i = 1 To 4
        tmp(i) = Replace(tmp(i), " ", "")
    Next i
 
 
 
 
 
 
 
prochaine_annee = tmp
End Function

C'est quoi le message d'erreur ?
Feuil1 est bien une feuille du classeur actif à ce moment de la procédure ?
nlignes ou ncolones peuvent ils être trop grand par rapport à la taille de la feuille ?

Tu as bien mis Option Explicit en début de module pour éviter déjà les erreurs de déclaration ?

Bonjour,

A tout hasard, remplace la ligne 198 par :

Code:

1
2
3
With Worksheets("Feuil1")
    Set MaZone = .Range(.Cells(100, 1), .Cells(100 + nlignes, 1 + ncolones))
End With

Effectivement, je n'ai pas eu le bon réflexe, c'est l'erreur habituelle, bien joué Daniel. J'espère que ça t'aura débloqué hobine.

A force de bidouiller, j'ai pu trouver.
Mais seulement, ce n'est pas la méthode que je veux utiliser. Je m'explique:
j'ai mon tableau (mon array) que je copie ses valeurs dans la feuil1 et par la suite je reviens recopier ces valeurs dans la feuille pour faire mon graphe.
Mon tableau se trouve sur la ligne 166 qui contient les valeurs qui vont être copiées à la feuille Feuil1. Comment éviter de passer par cette feuille intermédiaire?

Je voulais directement générer mon graphe à partir de mon array (tableau) sans passer une feuille intermédiaire. je n'y arrive pas, comment faire?
Code:

1 2 3 4 5 6 7 8 9 10 Set MaZone = Feuil1.Range("A109").CurrentRegion Charts.Add Call RemoveUnwantedSeries With ActiveChart .ChartType = xlColumnStacked .SetSourceData Source:=MaZone, PlotBy:=xlColumns ' .Location Where:=xlLocationAsObject, Name:="Feuil1" End With

Essaie un truc du genre :

Code:

ActiveChart.SeriesCollection(1).Values = monArray

Un petit exemple tout bête :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
Option Explicit
 
Public Sub test()
    Dim ch As Chart
    Set ch = Charts.Add
    ch.ChartType = xlColumnStacked
 
    Dim s As Series
    Set s = ch.SeriesCollection.NewSeries
 
    s.Values = Array(1, 2, 3, 4)
End Sub

je fais comme indiquer sauf que ça marche mais il y a une nouvelle série qui 'ajouter non seulement je ne connais pas d'où elles sortent et en plus je n'ai pas besoin, comment l’éliminer?

Je viens en effet de me rendre compte que cela ne marche pas ton programme
déjà un grand merci pour tout ce qui est jusqu'ici.
Code:

1 2 3 4 5 6 7 8 9 Set ch = Charts.Add ch.ChartType = xlColumnStacked Set S = ch.SeriesCollection.NewSeries S.Values = tableau

Désolé, mais je n'ai rien compris à ce que tu as écris. Peux-tu réessayer en te relisant ?

désole pour le style linguistique, j'aurai dû me relire.

bref, je me suis servi de ton programme mais elle ne fonctionne pas

C'est à dire ? Il ne se passe rien ? Ca bug ? Ce ne donne pas le résultat attendu ?

Tu l'as inséré de quelle manière dans ton programme ?

Etant donné que cela me parait encore plus compliqué, je préfère retenir l'option B qui était de copier dans une feuille et avant de générer mon graphe.

Pour ce qui était de ta proposition, pas bug, mais pas histogramme empilé i.e. résultat un graphe en bâton alors que mon je veux un graphe en barre empilé.

As tu une idée de comment regrouper tous mes graphes générés dans une seule feuille?

Cordialement

A adapter :

Code:

ActiveChart.Location Where:=xlLocationAsObject, Name:="Feuil1"