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 |
Partager