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
| Sub création_chaîne()
Dim ctr As Integer
Dim ctr1 As Integer
Dim ctr2 As Integer
Dim reponse As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("Workflow").Select
If Range("H2").Value = "Chaîne" Then
reponse = MsgBox("La Chaîne est déjà créée voulez vous la supprimer et la remplacer ?", vbExclamation + vbYesNo, "ATTENTION")
If reponse = vbNo Then Exit Sub
If reponse = vbYes Then
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Sheets("Liste Chaîne").Select
Range("A2:G2").Select
Range(Selection, Selection.End(xlDown)).Select 'Correspond au F8 CTRL + flêche(BAS)
Selection.ClearContents
Sheets("entretien").Select
Range("A2:c2").Select
Range(Selection, Selection.End(xlDown)).Select 'Correspond au F8 CTRL + flêche(BAS)
Selection.ClearContents
Sheets("acces_appli").Select
Range("A2:E2").Select
Range(Selection, Selection.End(xlDown)).Select 'Correspond au F8 CTRL + flêche(BAS)
Selection.ClearContents
Sheets("Workflow").Select
Range("H2").Select
End If
End If
Columns("H:H").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.NumberFormat = "@" ' format texte
Range("H2").Select
ActiveCell.FormulaR1C1 = "Chaîne" 'écriture de l'en tête de colonne
ctr = 0
ctr1 = 0
ctr2 = 0
For n = 3 To 1200
If Cells(n, 1) = "" Then GoTo 10
If Cells(n - 1, 1) <> Cells(n, 1) Then ctr = 0 'changement de département mise à zéro du compteur
If Cells(n - 1, 10) <> Cells(n, 10) Then 'à chaque changement d'évaluateur le compteur ajoute 1
ctr = ctr + 1
If ctr < 10 Then
Cells(n, 8).Value = Cells(n, 1) & 0 & ctr ' permet de rajouter un zéro devant un chiffre < 10
Else
Cells(n, 8).Value = Cells(n, 1) & ctr
End If
End If
If Cells(n - 1, 10) = Cells(n, 10) Then
If ctr < 10 Then
Cells(n, 8).Value = Cells(n, 1) & 0 & ctr
Else
Cells(n, 8).Value = Cells(n, 1) & ctr 'pas de changement d'évaluateur, le compteur ne bouge pas
End If
End If
Cells(n, 8).Select 'Colorisation de la colonne "Chaîne"
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = 2
.Color = 5296274
.TintAndShade = 0
.PatternTintAndShade = 0
End With
If Cells(n - 1, 8) <> Cells(n, 8) Then
ctr1 = ctr1 + 1
Sheets("Liste Chaîne").Cells(1 + ctr1, 1) = Cells(n, 8) ' Copie la chaîne et les matricules dans la feuille "Liste chaîne"
Sheets("Liste Chaîne").Cells(1 + ctr1, 2) = Cells(n, 9)
Sheets("Liste Chaîne").Cells(1 + ctr1, 3) = Cells(n, 11)
Sheets("Liste Chaîne").Cells(1 + ctr1, 4) = Cells(n, 13)
Sheets("Liste Chaîne").Cells(1 + ctr1, 5) = Cells(n, 15)
Sheets("Liste Chaîne").Cells(1 + ctr1, 6) = Cells(n, 17)
Sheets("Liste Chaîne").Cells(1 + ctr1, 7) = Cells(n, 19)
Sheets("acces_appli").Cells(1 + ctr1, 1) = Cells(n, 9) ' Copie la liste des matricules ayant l'accès
Sheets("acces_appli").Cells(1 + ctr1, 2) = Cells(n, 10)
Sheets("acces_appli").Cells(1 + ctr1, 3) = Cells(n, 21)
Sheets("acces_appli").Cells(1 + ctr1, 4) = Cells(n, 20)
End If
Sheets("entretien").Cells(n - 1, 1) = Cells(n, 4) ' Création des numéros d'entretien
Sheets("entretien").Cells(n - 1, 2) = "=CONCATENATE(RC[-1],""_ENT_ANN_2014"")"
Sheets("entretien").Cells(n - 1, 3) = Cells(n, 8)
Next
Call Insérer
10
MsgBox "Création des Chaînes terminée", vbInformation, "INFORMATION"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Insérer()
Sheets("Info").Select
Rows("10:39").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("acces_appli").Select
Rows("2:2").Select
Selection.Insert Shift:=xlDown
Range("A2").Select
Set MonDico = CreateObject("Scripting.Dictionary") 'Lorsqu'il y a un doublon dans la colonne A il conserve la ligne du premier doublon et supprime la 2ème
Application.ScreenUpdating = False
i = 1
Do While i < [A1048576].End(xlUp).Row
temp = Cells(i, "a")
If Not MonDico.Exists(temp) Then
MonDico(temp) = ""
i = i + 1
Else
Rows(i).EntireRow.Delete
End If
Loop
Range("f1").Select
ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C[-5]:R[1200]C[-5])"
End Sub |
