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