[XL-2003] comment programmer un graphique en bâton et en camembert sur vba? [Résolu]

[hobine]

Bonjour,
Etant débutant en programmation sur VBA, j'ai un problème. c'est pourquoi je me tourne vers vous.
le but est de generer un premier graphique en bâton dont l'axe des abscisse est la date de mutation et l'ordonnée le nombre de personne par date de mutation. i.e nbr pers = f(date de mutation). Et Le deuxième graphe est un camembert dont le pourcentage par service de mutation. J'ai commence à rediger une macro pleine de fautes.
Cette macro illustre d'une manière générale ce que je veux faire. Seulement , elle contient plusieurs erreurs dont je suis incapable de déboguer.
1. La première partie de ma macro consiste à effacer automatiquement la feuille graphe qui a été générée avant. Pour cela j'ai fait des sous routines. il y a bug.
2.Par la suite, je suis aller récupérer et compte le nombre de personnes désirant être mutée par période et par service. (je pense sur cette partie tout va bien. Par contre, je parviens à bien rédiger la matrice me permettant d'avoir mon graphe en bâton pour ce qui est nbre. pers = f(période) et pourcentage de personne voulant être mutée par direction.
Vous trouverez ci dessous ma macro et ses sous-routines, je remercie toute personne de bonne volonté pouvant me sortir de cette galère

==================================================

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
Option Explicit
 
Sub CreateChart()
Dim Plage As Range
Dim direction_mutation() As Variant
Dim periode_mutation() As Variant
Dim PossDirection() As Variant, PossPeriode() As Variant
Dim i As Integer, j As Integer, nl As Integer
Dim nligne As Integer
Dim itrimestre As Integer
Dim myexcelfile As String
Dim chemin As String
Dim tableau() As String
Dim tableau2() As Integer
Dim merde As String
 
 
 
chemin = ThisWorkbook.Path
 
myexcelfile = ThisWorkbook.Name
 
' mysheet =
' Set xlBook = Workbooks.Open(chemin & "\" & myexcelfile)
' Set xlSheet = xlBook.Sheets("S1UET1")
 
Charts.Add
 
 
 
 
MsgBox "pouet"
' !!!!!!!!!!!!!! avant de commencer il faut supprimer toutes les feuilles graphiques
'récupération des directions de mutation
 
Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row + 1)
direction_mutation = Plage.Value
 
'récupération des valeurs possibles des directions en utilisant la fonction qui supprime les doublons
ReDim PossDirection(UBound(direction_mutation, 1))
For i = 1 To UBound(direction_mutation, 1)
PossDirection(i) = direction_mutation(i, 1)
Next i
PossDirection = SupprimerDoublons(PossDirection)
 
 
' récupération des trimestres et années de mutation
Set Plage = Range("B2:B" & Range("B65536").End(xlUp).Row + 1)
periode_mutation = Plage.Value
 
ReDim PossPeriode(UBound(periode_mutation, 1))
For i = 1 To UBound(periode_mutation, 1)
PossPeriode(i) = periode_mutation(i, 1)
Next i
PossPeriode = SupprimerDoublons(PossPeriode)
 
 
ReDim Mutant(UBound(PossDirection), UBound(PossPeriode))
For i = 1 To UBound(PossDirection)
For j = 1 To UBound(PossPeriode)
Mutant(i, j) = 0
Next j
Next i
 
 
For nligne = 1 To UBound(direction_mutation, 1)
 
For i = 1 To UBound(PossDirection)
For j = 1 To UBound(PossPeriode)
If (direction_mutation(nligne, 1) = PossDirection(i)) Then
If (periode_mutation(nligne, 1) = PossPeriode(j)) Then
Mutant(i, j) = Mutant(i, j) + 1
End If
End If
 
 
Next j
Next i
Next nligne
 
 
'graph pour le T1-2012
For i = 1 To UBound(PossPeriode)
If PossPeriode(i) = "T1-2012" Then
itrimestre = i
End If
Next i
MsgBox "so farsogood"
 
 
 
'MsgBox tableau(1)
 
With ActiveChart
.SeriesCollection.NewSeries
.SeriesCollection(1).XValues = periode_mutation() 'Abscisses
.SeriesCollection(1).Values = PossDirection() 'Ordonnées
'Définit le type (Courbe)
.ChartType = xlColumnClustered
End With
 
 
 
 
 
 
 
 
 
 
 
' 1ère étape: on lit la colonne des directions et on détermine les directions possibles
 
' Select the cell in the upper-left corner of the chart.
' Range("c4").Select
' Select the current range of data. This line of code assumes that
' the current region of cells is contiguous - without empty rows
' or columns.
' Selection.CurrentRegion.Select
 
' Assign the address of the selected range of cells to a variable.
' myrange = Selection.Address
 
 
 
 
 
' Application.CutCopyMode = False
 
' This line can best be written by recording a macro, and
' modifying the code generated by the Microsoft Excel Macro
' recorder.
 
' ActiveChart.ChartWizard _
' Source:=Sheets(mysheetname).Range(myrange), _
' Gallery:=xlLine, Format:=4, PlotBy:=xlRows, _
' CategoryLabels:=1, SeriesLabels:=1, HasLegend:=1, _
' Title:="", CategoryTitle:="", _
' ValueTitle:="", ExtraTitle:=""
 
End Function
 
 
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
 
Sub nettoieFeuilleGraph(fichier As String)
Dim test As Boolean
Dim n As Integer
Dim i As Integer
 
 
 
Application.DisplayAlerts = False
Set xlBook = Workbooks.Open(fichier)
MsgBox Worksheets.Count
n = Worksheets.Count
For i = 1 To n
 
test = WsExist("Graph" + Str(i))
MsgBox test
 
If test = True Then
Worksheets("Graph" + Str(i)).Delete
End If
 
 
 
Next i
Application.DisplayAlerts = True
ActiveWorkbook.Save
 
End Sub
 
Function WsExist(nomFeuil As String) As Boolean
On Error Resume Next
WsExist = Sheets(nomFeuil).Index
End Function

=========================================


Je vous remercie d'avance.

[Daniel.C]

Bonjour,

il y a bug

Oui. Sur quelle ligne; quel est le message d'erreur ?

[hobine]

C'est juste le problème sur ma macro. En effet elle ne signale pas d'erreur (pas un message d'erreurs )mais par contre elle exécute des choses qui n'ont rien à voir avec ce que je veux faire. par, elle ouvre une fenêtre de graphe mais celle-ci est vide. si j'exécute de nouveau le programme, elle ne supprime pas l'ancienne fenêtre alors cela a été écrite.
Le graphe en soit, n'est pas du tout tracé
J'ai illustré mon besoin par un petit exemple que tu pourras voir sur le fichier excel en pièce jointe.

Merci d'avance de vous soucier de mon cas

[Daniel.C]

Tu essaies de faire un graphique avec les variables "Tableau" en abscisse et "Tableau2" en ordonnées. Or, nulle part, tu ne remplis ces variables. Que veux-tu mettre dans ton graphique ? Donne-moi les plages de cellules.

[hobine]

je veux faire un premier graphe en bâton montrant le nombre de personne mutée en fonction la date de mutation.
Le second graphe (un camembert) est la répartition en pourcentage par service de mutation.

[Daniel.C]

Regarde cette macro qui crée le premier graphique. Dis-moi si c'est correct :

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
Sub CreateChart2()
    Dim Plage As Range
    Dim direction_mutation As Variant
    Dim periode_mutation As Variant
    Dim PossDirection As Variant, PossPeriode As Variant
    Dim i As Integer, j As Integer, nl As Integer
    Dim nligne As Integer
    Dim itrimestre As Integer
    Dim myexcelfile As String
    Dim chemin As String
    Dim sh
 
   chemin = ThisWorkbook.Path
   myexcelfile = ThisWorkbook.Name
   For Each sh In Sheets
       If Left(sh.Name, 5) = "GRAPH" Then sh.Delete
   Next sh
 
 
    Charts.Add
 
    Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row)
    PossDirection = Application.Transpose(Plage.Value)
 
    'récupération des valeurs possibles des directions en utilisant la fonction qui supprime les doublons
    PossDirection = SupprimerDoublons(PossDirection)
 
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("B2:B" & Range("B65536").End(xlUp).Row)
    PossPeriode = Application.Transpose(Plage.Value)
 
    PossPeriode = SupprimerDoublons(PossPeriode)
    Dim tableau() As Long
    ReDim tableau(1 To UBound(PossPeriode))
    For i = 1 To UBound(PossPeriode)
        tableau(i) = Application.CountIf(Plage, PossPeriode(i))
    Next i
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossPeriode  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        'Définit le type (Courbe)
        .ChartType = xlColumnClustered
    End With
 
 End Sub

... et avec le camembert :

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
Sub CreateChart2()
    Dim Plage As Range
    Dim direction_mutation As Variant
    Dim periode_mutation As Variant
    Dim PossDirection As Variant, PossPeriode As Variant
    Dim i As Integer, j As Integer, nl As Integer
    Dim nligne As Integer
    Dim itrimestre As Integer
    Dim myexcelfile As String
    Dim chemin As String
    Dim sh
 
   chemin = ThisWorkbook.Path
   myexcelfile = ThisWorkbook.Name
   Application.DisplayAlerts = False
   For Each sh In Sheets
       If Left(sh.Name, 5) = "Graph" Then sh.Delete
   Next sh
   Application.DisplayAlerts = True
 
    Charts.Add
 
    Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row)
    PossDirection = Application.Transpose(Plage.Value)
 
    'récupération des valeurs possibles des directions en utilisant la fonction qui supprime les doublons
    PossDirection = SupprimerDoublons(PossDirection)
 
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("B2:B" & Range("B65536").End(xlUp).Row)
    PossPeriode = Application.Transpose(Plage.Value)
 
    PossPeriode = SupprimerDoublons(PossPeriode)
    Dim tableau() As Double
    ReDim tableau(1 To UBound(PossPeriode))
    For i = 1 To UBound(PossPeriode)
        tableau(i) = Application.CountIf(Plage, PossPeriode(i))
    Next i
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossPeriode  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        'Définit le type (Courbe)
        .ChartType = xlColumnClustered
    End With
    ReDim tableau(1 To UBound(PossDirection))
    Set Plage = Plage.Offset(, 1)
    For i = 1 To UBound(PossDirection)
        tableau(i) = Application.CountIf(Plage, PossDirection(i)) / UBound(PossDirection)
    Next i
    Charts.Add
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        'Définit le type (Courbe)
        .ChartType = xlPie
    End With
 End Sub

[hobine]

Merci Daniel pour ta réponse, j'ai modifié un peu ta proposition pour obtenir ce que je voulais. cependant j'ai 3 nouveaux problèmes qui se posent.
1. je voudrais faire afficher par période croissante au niveau des abscisse sur mon graphe en bâton. par exple. de T1-2012 à T4-2013
2. le graphe camembert doit contenir uniquement la répartition par service de mutation de la plus petite année. Expl. Dans le graphe bâton, 2012 est la plus petite année, alors l'on récupère les données de celle-ci et fait un camembert par service de mutation.
3. faire afficher sur mon graphe camembert à l’intérieur de répartition le nom de service de mutation et leur pourcentage.
Tu trouvera en dessous la version améliorer de ma macro.

merci d'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
Sub CreateChart()
    Dim Plage As Range
    Dim PossDirection() As Variant, PossPeriode() 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
 
 
    If WsExist("result") = True Then
         Worksheets("result").Delete
    End If
 
    For Each sh In Sheets
       If Left(sh.Name, 5) = "Graph" Then sh.Delete
   Next sh
 
 
 
 
    'récupération des directions de mutation
 
    Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row)
    PossDirection = Application.Transpose(Plage.Value)
    listeDirection = PossDirection
    PossDirection = SupprimerDoublons(PossDirection)
 
    ' récupération des listes métiers
    Set Plage = Range("D2:D" & Range("D65536").End(xlUp).Row)
    listeMetier = Application.Transpose(Plage.Value)
    listeMetier = SupprimerDoublons(listeMetier)
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("B2:B" & Range("B65536").End(xlUp).Row)
    PossPeriode = Application.Transpose(Plage.Value)
    PossPeriode = SupprimerDoublons(PossPeriode)
 
 
 
 
    ' PossPeriode = range_croissant(PossPeriode)
 
 
    ' Graph Bâton
    Charts.Add
    Dim tableau() As Long
    ReDim tableau(1 To UBound(PossPeriode))
    For i = 1 To UBound(PossPeriode)
        tableau(i) = Application.CountIf(Plage, PossPeriode(i))
    Next i
    With ActiveChart
        'SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossPeriode  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        .ChartType = xlColumnClustered   'type de graph
    End With
 
 
    ' Camembert
    ' il faudra sélectionner ceux qui vont muter dans la prochaine année
    ' il faut remplir différemment le tableau
    Dim tableau2() As Double
    ReDim tableau2(1 To UBound(PossDirection))
    d = 1 / UBound(PossDirection)
    Set Plage = Plage.Offset(, 1)
    For i = 1 To UBound(PossDirection)
        tableau2(i) = Application.CountIf(Plage, PossDirection(i)) * d
    Next i
 
    Charts.Add
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
    End With
 
 
    'camembert de la DCT
    ' récupération des métiers de la DCT
    ncount = 0
    For i = 1 To UBound(listeDirection)
       If listeDirection(i) = "DCT" Then
            ncount = ncount + 1
        End If
    Next i
 
 
    ReDim tbl(ncount)
    ncount = 0
    For i = 1 To UBound(listeDirection)
       If listeDirection(i) = "DCT" Then
            ncount = ncount + 1
            tbl(ncount) = listeMetier(i)
        End If
    Next i
    sous_tableDCT = tbl
    tbl = SupprimerDoublons(tbl)
 
 
  ' créer le tableau 2
 
   ReDim tableau2(1 To UBound(tbl))
    d = 1 / UBound(tbl)
    Set Plage = Plage.Offset(, 1)
   For i = 1 To UBound(tbl)
        tableau2(i) = Application.CountIf(sous_tableDCT, tbl(i)) * d
    Next i
   '
   Charts.Add
    With ActiveChart
    '    .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = tbl  'Abscisses
      .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
   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 range_croissant(tbl()) As Variant()
    Dim tmp() As Variant
    Dim tmp1() As String
    Dim trim() As Variant
    Dim min_an As Integer
    Dim max_an As Integer
    Dim trimes(4) As String, annees() As String
 
 
    trimes(1) = "T1-"
    trimes(2) = "T2-"
    trimes(3) = "T3-"
    trimes(4) = "T4-"
    MsgBox tbl(1)
    ReDim tmp1(UBound(tbl))
    For i = 1 To UBound(tbl)
        tmp1(i) = Split(Str(tbl(i)), "-")
    Next i
    ' chercher le min d'année
    ' chercher le max d'année
    min_an = 21000
    max_an = 2000
 
   For i = 1 To UBound(tmp1, 1)
        If Val(tmp1(i, 2)) < min_an Then
            min_an = Val(tmp1(i, 2))
        End If
        If Val(tmp1(i, 2)) < max_an Then
            max_an = Val(tmp1(i, 2))
        End If
    Next i
 
    nannees = max_an - min_an + 1
    ReDim annees(nannees)
    For i = 1 To nannees
        annees(i) = Str(min_an + (i - 1))
        MsgBox annees(i)
    Next i
 
    ncount = 0
    For i = 1 To nannees
        For j = 1 To 4
            For k = 1 To UBound(tbl)
                If tbl(k) = trimes(j) & annees(i) Then
                    ncount = ncount + 1
                    tmp(ncount) = tbl(k)
                    MsgBox tmp(ncount)
                End If
 
            Next k
        Next j
    Next i
 
 
   range_croissant = tmp
   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

[Daniel.C]

Essaie cette macro :

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
Sub CreateChart()
    Dim Plage As Range
    Dim PossDirection() As Variant, PossPeriode() 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
 
    Application.DisplayAlerts = False
    If WsExist("result") = True Then
         Worksheets("result").Delete
    End If
 
    For Each sh In Sheets
       If Left(sh.Name, 5) = "Graph" Then sh.Delete
   Next sh
    Application.DisplayAlerts = True
 
 
 
    'récupération des directions de mutation
 
    Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row)
    PossDirection = Application.Transpose(Plage.Value)
    listeDirection = PossDirection
    PossDirection = SupprimerDoublons(PossDirection)
 
    ' récupération des listes métiers
    Set Plage = Range("D2:D" & Range("D65536").End(xlUp).Row)
    listeMetier = Application.Transpose(Plage.Value)
    listeMetier = SupprimerDoublons(listeMetier)
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("B1:B" & Range("B65536").End(xlUp).Row)
    [M:O].ClearContents
    Plage.AdvancedFilter xlFilterCopy, copytorange:=[M1], unique:=True
    For Each c In Range([M2], Cells(Rows.Count, 13).End(xlUp))
        c.Offset(, 1) = Left(c.Value, 2)
        c.Offset(, 2) = CInt(Right(c.Value, 4))
    Next c
    Range([N2], Cells(Rows.Count, 15).End(xlUp)).Select
    Range([N2], Cells(Rows.Count, 15).End(xlUp)).Sort [O2], xlAscending, key2:=[N2], order2:=xlAscending, header:=xlNo
    Range([N2], Cells(Rows.Count, 15).End(xlUp)).Copy
    [N2].PasteSpecial xlPasteValues
    For Each c In Range([M2], Cells(Rows.Count, 13).End(xlUp))
        c.Value = c.Offset(, 1) & "-" & c.Offset(, 2)
        c.Offset(, 2) = CInt(Right(c.Value, 4))
    Next c
    PossPeriode = Application.Transpose(Range([M2], Cells(Rows.Count, 13).End(xlUp)).Value)
 
 
 
    ' PossPeriode = range_croissant(PossPeriode)
 
 
    ' Graph Bâton
    Charts.Add
    Dim tableau() As Long
    ReDim tableau(1 To UBound(PossPeriode))
    For i = 1 To UBound(PossPeriode)
        tableau(i) = Application.CountIf(Plage, PossPeriode(i))
    Next i
    With ActiveChart
        'SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossPeriode  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        .ChartType = xlColumnClustered   'type de graph
    End With
 
 
    ' Camembert
    ' il faudra sélectionner ceux qui vont muter dans la prochaine année
    ' il faut remplir différemment le tableau
    Dim tableau2() As Double
 
ReDim tableau2(1 To UBound(PossDirection))
    d = 1 / UBound(PossDirection)
    For i = 2 To Plage.Count
        If CInt(Right(Cells(i, 2), 4)) = [O2].Value Then
            tableau2(Application.Match(Cells(i, 3).Value, PossDirection, 0)) = _
            tableau2(Application.Match(Cells(i, 3).Value, PossDirection, 0)) + 1
        End If
    Next i
 
    Charts.Add
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
        .HasLegend = False
        .SeriesCollection(1).ApplyDataLabels AutoText:=True, LegendKey:= _
            False, HasLeaderLines:=True, ShowSeriesName:=False, ShowCategoryName:= _
            True, ShowValue:=False, ShowPercentage:=True, ShowBubbleSize:=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
    End With
 
 
    'camembert de la DCT
    ' récupération des métiers de la DCT
    ncount = 0
    For i = 1 To UBound(listeDirection)
       If listeDirection(i) = "DCT" Then
            ncount = ncount + 1
        End If
    Next i
 
 
    ReDim tbl(ncount)
    ncount = 0
    For i = 1 To UBound(listeDirection)
       If listeDirection(i) = "DCT" Then
            ncount = ncount + 1
            tbl(ncount) = listeMetier(i)
        End If
    Next i
    sous_tableDCT = tbl
    tbl = SupprimerDoublons(tbl)
 
 
  ' créer le tableau 2
 
   ReDim tableau2(1 To UBound(tbl))
    d = 1 / UBound(tbl)
    Set Plage = Plage.Offset(, 1)
   For i = 1 To UBound(tbl)
        tableau2(i) = Application.CountIf(sous_tableDCT, tbl(i)) * d
    Next i
   '
   Charts.Add
    With ActiveChart
    '    .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = tbl  'Abscisses
      .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
   End With
    [M:O].ClearContents
 
 End Sub

[hobine]

Bonjour Daniel,
je suis desolé de n'avoir pas pu te répondre hier.
il y a 2 problèmes avec ta macro:
1 je me rends compte qu'elle ecrit les resultats dans la feuille de données. En realite, cette feuille est standard, i.e non modifiable. n'est pas possible de faire classification et ranger le nbre de mutant par année croissante directement?

2 il y a un bug sur cette ligne de code de ta macro, que je ne crompreds pas

Code :

If CInt(Right(Cells(i, 2), 4)) = [O2].Value Then

merci

[hobine]

Rebonjour Daniel,
J'ai un petit problème dans cette macro pour le copier coller d'un classeur à un autre(celle-ci n'a rien à voir avec celui du graphe).
ci-dessus , tu trouveras la macro et le probleme se trouve sur la ligne :ActiveSheet.Paste
Tout me semble pourtant correct
merci

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
Sub COPIEBASEVG()
 
Workbooks.Open Filename:="C:\Documents and Settings\Desktop\ModeleSimple\Service1\UET1.xls"
'  Sheets("S1UET1").Activate
'  Range("A2:D7").Copy
Workbooks.Open Filename:="C:\Documents and Settings\Desktop\ModeleSimple\Service1\Service1.xls"
'Windows("detail.xls").Activate
'  Sheets("feuille de detail").Activate
'  Range("C9").Select
'  ActiveSheet.Paste
Windows("UET1.xls").Activate
  Sheets("S1UET1").Activate
  Range("B2:D7").Copy
Workbooks.Open Filename:="C:\Documents and Settings\Desktop\ModeleSimple\Service1\Service1.xls"
 
Windows("Service1.xls").Activate
  Sheets("feuille de detail").Activate
  Range("D9").Select
  ActiveSheet.Paste
'Windows("export.xls").Close
'Windows("essai copie fichier2.xls").Close
  'Sheets("MENU").Select
 
End Sub

[Daniel.C]

En réponse du 20/11/11 11:03 :

Est-ce que tu testes avec le classeur que tu m'as fait parvenir ? quel est le message d'erreur ?

1 je me rends compte qu'elle ecrit les resultats dans la feuille de données. En realite, cette feuille est standard, i.e non modifiable. n'est pas possible de faire classification et ranger le nbre de mutant par année croissante directement?

Bien sûr, mais c'est beaucoup plus compliqué. Je vais ajouter une feuille que je supprimerai en fin de macro.

En réponse du 20/11/11 11:59 :

Ouvre un nouveau fil pour cette question. Je ne pourrai pas la traiter aujourd'hui.

[mercatog]

Pour ouvrir 2 classeurs, copier des données de l'un vers l'autre, enregistrer le 2ème et fermer les 2. Il est recommandé de travailler avec des variables sans rien activer ni sélectionner

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub COPIEBASEVG()
Dim Wbk As Workbook, Wbks As Workbook
Dim Rep As String
 
 
Rep = "C:\Documents and Settings\Desktop\ModeleSimple\Service1\"
Set Wbk = Workbooks.Open(Rep & "UET1.xls")
Set Wbks = Workbooks.Open(Rep & "Service1.xls")
 
Wbk.Worksheets("S1UET1").Range("B2:D7").Copy Wbks.Worksheets("feuille de detail").Range("D9")
 
Wbk.Close False
Wbks.Close True
Set Wbk = Nothing
Set Wbks = Nothing
End Sub

[hobine]

Merci Mercatog,

Cette routine fonctionne très bien. Par contre, certaines cellules qu'on copie sont des menus déroulants. Quand on exécute la macro, un message d'erreur nous dit que le fichier de destination contient déjà les mots-clés du fichier source. Comment faire pour ne plus avoir ce message?

[mercatog]

Je n'ai pas compris, mais 2 variantes

1. remplace la ligne 10 par celle-ci

Code :

Wbks.Worksheets("feuille de detail").Range("D9:F14").Value = Wbk.Worksheets("S1UET1").Range("B2:D7").Value

2. désactive les alertes autour de la ligne 10

Code :

1
2
3
Application.DisplayAlerts = False
Wbk.Worksheets("S1UET1").Range("B2:D7").Copy Wbks.Worksheets("feuille de detail").Range("D9")
Application.DisplayAlerts = True

[hobine]

Bonjour Daniel et autres,
J'ai bidouillé et finalement trouver la solution me permettant de générer mes graphes. Mais seulement, en voulant faire le troisième graphe qui consiste à faire une répartition graphique des métiers de la "DCT" au cours de l'année minimale

Il y a un bug que je n'arrive pas à trouver la solution. Pourras-tu jeter un coup d'oeil sur ma macro ci-dessous, et me délivrer de cette souffrance?

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
Sub CreateChartPouet(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
 
 
 
    For Each sh In Sheets
       If Left(sh.Name, 5) = "Graph" Then sh.Delete
   Next sh
    Application.DisplayAlerts = True
 
    Worksheets(feuille).Activate
 
 
 
    'récupération des directions de mutation
 
    Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row)
    PossDirection = Application.Transpose(Plage.Value)
    listeDirection = PossDirection
    PossDirection = SupprimerDoublons(PossDirection)
 
 
 
    ' récupération des listes métiers
    Set Plage = Range("D2:D" & Range("D65536").End(xlUp).Row)
    listeMetier = Application.Transpose(Plage.Value)
    listeMetier = PossMetier
    PossMetier = SupprimerDoublons(PossMetier)
 
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("B2:B" & Range("B65536").End(xlUp).Row)
    PossPeriode = Application.Transpose(Plage.Value)
    listeperiode = PossPeriode
    PossPeriode = SupprimerDoublons(PossPeriode)
    SPossPeriode = range_croissant(PossPeriode)
    For i = 1 To UBound(PossPeriode)
        PossPeriode(i) = SPossPeriode(i)
    Next i
    ' Graph Bâton
    Charts.Add
    Dim tableau() As Long
    ReDim tableau(1 To UBound(PossPeriode))
    For i = 1 To UBound(PossPeriode)
        tableau(i) = Application.CountIf(Plage, PossPeriode(i))
    Next i
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossPeriode  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        .ChartType = xlColumnClustered   'type de graph
    End With
 
 
 
    possannee1 = premiere_annee(PossPeriode)
 
    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
 
 
    ReDim dirannee1(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
                dirannee1(ncount) = listeDirection(i)
            End If
        Next j
 
    Next i
 
   ReDim tableau2(UBound(PossDirection))
   For i = 1 To UBound(dirannee1)
    For j = 1 To UBound(PossDirection)
        If dirannee1(i) = PossDirection(j) Then
            MsgBox "direction"
            MsgBox dirannee1(i)
            MsgBox PossDirection(j)
            tableau2(j) = tableau2(j) + 1
        End If
    Next j
    Next i
 
 
   ' For i = 1 To UBound(tableau2)
   '     tableau2(j) = tableau2(j) / UBound(tableau2)
   ' Next i
 
 
 
 
 
   ' PossPeriode
 
 
    ' Camembert
    ' il faudra sélectionner ceux qui vont muter dans la prochaine année
    ' il faut remplir différemment le tableau
   ' Dim tableau2() As Double
 
   ' ReDim tableau2(1 To UBound(PossDirection))
   ' d = 1 / UBound(PossDirection)
   ' For i = 2 To Plage.Count
  '      If CInt(Right(Cells(i, 2), 4)) = [O2].Value Then
   '         tableau2(Application.Match(Cells(i, 3).Value, PossDirection, 0)) = _
            tableau2(Application.Match(Cells(i, 3).Value, PossDirection, 0)) + 1
   '     End If
   ' Next i
 
    Charts.Add
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
        .HasLegend = False
        .SeriesCollection(1).ApplyDataLabels AutoText:=True, LegendKey:= _
            False, HasLeaderLines:=True, ShowSeriesName:=False, ShowCategoryName:= _
            True, ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False, Separator _
        :="" & Chr(10) & ""
        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
    End With
 
 
    MsgBox "fin du camembert"
 
 
    'camembert de la DCT
    ' récupération des métiers de la DCT
    ncount = 0
    For i = 1 To UBound(listeDirection)
       If listeDirection(i) = "DCT" Then
            ncount = ncount + 1
        End If
    Next i
 
 
    ReDim tbl(ncount)
    ncount = 0
    For i = 1 To UBound(listeDirection)
       If listeDirection(i) = "DCT" Then
            ncount = ncount + 1
            tbl(ncount) = listeMetier(i)
        End If
    Next i
    sous_tableDCT = tbl
    tbl = SupprimerDoublons(tbl)
 
 
  ' créer le tableau 2
 
   ReDim tableau2(1 To UBound(tbl))
    d = 1 / UBound(tbl)
    Set Plage = Plage.Offset(, 1)
   For i = 1 To UBound(tbl)
        tableau2(i) = Application.CountIf(sous_tableDCT, tbl(i)) * d
    Next i
 
 
    '
   Charts.Add
    With ActiveChart
    '    .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = tbl()  'Abscisses
      .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
   End With
    [M:O].ClearContents
 
 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
        tmp(i) = "autre"
    Next i
 
    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

[Daniel.C]

Ca fait trois fois que tu me dis :

Il y a un bug

Précise plutôt la ligne qui pose problème et le message d'erreur.

[hobine]

Dans la sous-routine supprimer doublons, (ligne 221)
mais je pense que le problème est ailleurs, car jusqu'aux 2 premières graphes( répartition nbr. de mutant par année pour le premier graphe et répartition par direction sur la plus petite année) tout allait très bien, depuis que j'ai écrit l'algorithme du graphe pour la répartition par métier du service de mutation pour la plus petite année. Aucun graphe précédent ne s'affiche.

Merci par avance

[Daniel.C]

Oui, mais je ne me suis pas servi de ta routine pour les deux premiers graphiques. Je regarde.

[Daniel.C]

Remplace la ligne 38 par :

Code :

    PossMetier = listeMetier

Vérifie que ça fait bien ce que tu veux.

[hobine]

merci Daniel,
ça m'aide beaucoup, sans toutefois résoudre tous mes problèmes. J'ai pu avancer comme une torture, j’espère que j'y arriverai un jour.
Par contre, j'ai une question au niveau du graphique du camembert: il y a un décalage dans les légendes: disons que par exemple j'ai:
A1 quantité 1
A2 quantité 2
A3 quantité 3:

Si mon camembert ne retient que les catégories A1 et A3 il va prendre les bonnes quantités mais afficher les légendes A2 et rien du tout.

J'ai trouvé la solution. Il y avait un problème de numérotation (tableau des données de 1 à N tableau des valeurs de 0 à N)

Merci pour l'aide, j'inclus la macro finale ou cas cela peut aider quelqu'un

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
Sub CreateChartPouet(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
 
 
 
    For Each sh In Sheets
       If Left(sh.Name, 5) = "Graph" Then sh.Delete
   Next sh
    Application.DisplayAlerts = True
 
    Worksheets(feuille).Activate
 
 
 
    'récupération des directions de mutation
 
    Set Plage = Range("C2:C" & Range("C65536").End(xlUp).Row)
    PossDirection = Application.Transpose(Plage.Value)
    listeDirection = PossDirection
    PossDirection = SupprimerDoublons(PossDirection)
 
 
 
    ' récupération des listes métiers
    Set Plage = Range("D2:D" & Range("D65536").End(xlUp).Row)
    PossMetier = Application.Transpose(Plage.Value)
    listeMetier = PossMetier
    PossMetier = SupprimerDoublons(PossMetier)
 
 
    ' récupération des trimestres et années de mutation
    Set Plage = Range("B2:B" & Range("B65536").End(xlUp).Row)
    PossPeriode = Application.Transpose(Plage.Value)
    listePeriode = PossPeriode
    PossPeriode = SupprimerDoublons(PossPeriode)
    SPossPeriode = range_croissant(PossPeriode)
    For i = 1 To UBound(PossPeriode)
        PossPeriode(i) = SPossPeriode(i)
    Next i
    ' Graph Bâton
    Charts.Add
    Dim tableau() As Long
    ReDim tableau(1 To UBound(PossPeriode))
    For i = 1 To UBound(PossPeriode)
        tableau(i) = Application.CountIf(Plage, PossPeriode(i))
    Next i
    With ActiveChart
       ' .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossPeriode  'Abscisses
        .SeriesCollection(1).Values = tableau 'Ordonnées
        .ChartType = xlColumnClustered   'type de graph
    End With
 
 
 
    possannee1 = premiere_annee(PossPeriode)
 
    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
 
 
    ReDim dirannee1(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
                dirannee1(ncount) = listeDirection(i)
            End If
        Next j
 
    Next i
 
   ReDim tableau2(1 To UBound(PossDirection))
   For i = 1 To UBound(dirannee1)
    For j = 1 To UBound(PossDirection)
        If dirannee1(i) = PossDirection(j) Then
 
            tableau2(j) = tableau2(j) + 1
        End If
    Next j
    Next i
 
    For i = 1 To UBound(tableau2)
        MsgBox PossDirection(i)
        MsgBox tableau2(i)
    Next i
 
    Charts.Add
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = PossDirection  'Abscisses
        .SeriesCollection(1).Values = tableau2 'Ordonnées
        .ChartType = xlPie
        .HasLegend = False
        .SeriesCollection(1).ApplyDataLabels AutoText:=True, LegendKey:= _
            False, HasLeaderLines:=True, ShowSeriesName:=False, ShowCategoryName:= _
            True, ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False, Separator _
        :="" & Chr(10) & ""
        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
    End With
 
 
    MsgBox "fin du camembert"
 
 
    'camembert de la DCT
    ' récupération des métiers de la DCT
    ncount = 0
    For i = 1 To UBound(listeDirection)
        If listeDirection(i) = "DCT" Then
            For j = 1 To UBound(possannee1)
                If listePeriode(i) = possannee1(j) Then
                    ncount = ncount + 1
                End If
            Next j
        End If
 
    Next i
 
 
    ReDim tbl(1 To ncount)
    ncount = 0
     For i = 1 To UBound(listeDirection)
        If listeDirection(i) = "DCT" Then
            For j = 1 To UBound(possannee1)
                If listePeriode(i) = possannee1(j) Then
                    ncount = ncount + 1
                    tbl(ncount) = listeMetier(i)
                End If
            Next j
        End If
    Next i
    sous_tableDCT = tbl
    tbl = SupprimerDoublons(tbl)
 
 
  ' créer le tableau 2
 
    ReDim tableau2(1 To UBound(tbl))
    For i = 1 To UBound(sous_tableDCT)
        For j = 1 To UBound(tbl)
            If sous_tableDCT(i) = tbl(j) Then
                tableau2(j) = tableau2(j) + 1
            End If
        Next j
    Next i
 
 
 
   Charts.Add
    With ActiveChart
        .SeriesCollection.NewSeries
        .SeriesCollection(1).XValues = tbl  'Abscisses
      .SeriesCollection(1).Values = tableau2 '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
   End With
 '   [M:O].ClearContents
 
 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
        tmp(i) = "autre"
    Next i
 
    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