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
| Sub genere_onglets_etablissement_filtre_elab_4()
On Error GoTo errorhandler:
Dim LettreVoulue As String
Dim nom_etablissement As Variant
Dim start As Single
Dim finish As Single
Dim etab_x As Variant
start = Timer
Application.ScreenUpdating = False
'validation si la feuille départ existe
If sheetExists("R_MoulinetteAValider") = False Then
MsgBox "Erreur d'exécution, feuille R_MoulinetteAValider manquante", vbCritical
Exit Sub
End If
Application.DisplayAlerts = False
'destruction de la feuille parametre lors de la réexécution de la sub
If sheetExists("param") = True Then
Sheets("param").Delete
Else
End If
'retrait des caractères spéciaux afin d'éviter d'avoir un erreur lors de la génération des onglets
Sheets("R_MoulinetteAValider").Select
LettreVoulue = TrouveLettreColonne([acronyme_etab])
Sheets("R_MoulinetteAValider").Range(LettreVoulue & 2, LettreVoulue & LastLignUsedInSheet("R_MoulinetteAValider")).Select
Selection.Replace What:=Chr(47), Replacement:=Chr(32)
Selection.Replace What:=Chr(92), Replacement:=Chr(32)
Selection.Replace What:=Chr(91), Replacement:=Chr(32)
Selection.Replace What:=Chr(93), Replacement:=Chr(32)
'nettoyer seul est une fonction qui enleve les espace superflus et mt les caractères en majuscule
nettoyerseul
'nommer la plage de début afin de facilité le code
Sheets("R_MoulinetteAValider").Range("a2").CurrentRegion.Name = "plage_debut"
'création de la feuille de param (feuille de paramêtre)
Sheets.Add.Name = "param"
'copie de l'entete a l'aide de la feuille de départ
With Sheets("R_MoulinetteAValider")
With Union(.Range(.Range(TrouveLettreColonne([ID_titre]) & 1), .Range(TrouveLettreColonne([prix_contrat_titre]) & 1)), _
.Range(.Range(TrouveLettreColonne([valider_etablissement_titre]) & 1), .Range(TrouveLettreColonne([commentaire_etablissement_titre]) & 1)))
With .Copy
With Sheets("param").Range("i1")
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
End With
End With
End With
'remplir la feuille parametre afin d'uitilisé celle ci
With Sheets("param")
'mettre le titre acronyme établissement afin de pouvoir faire le filtre
.Range("a1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
.Range("d1").value = Sheets("R_MoulinetteAValider").[acronyme_etab_titre].value
'mettre le titre à valider afin de pouvoir fair ele filtre avec le "X"
.Range("e1").value = Sheets("R_MoulinetteAValider").[valider_etablissement_titre].value
'mettre le X dans la colonne
.Range("e2").value = "X"
'nommé la plage de l'acronyme afin de facilité le code et la zone auquel je copie les données et transfert dans la bonne feuille
.Range("d2").CurrentRegion.Name = "critere_1"
.Range("i2").CurrentRegion.Name = "receptrice"
End With
'copie des acronyme des établissement unique dans la feuille parametre
Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Sheets("param").Range("critere_1"), CopyToRange:=Sheets("param").Range("A1:A2"), Unique:=True
'nommé la plage d'acronyme unique afin de faciliter le code
Sheets("param").Range("a2:a" & LastLignUsedInColumn("a")).Name = "critere_2"
'Validation si les feuilles contenant le nom des acronym unique existe sinon la créer
For Each etab_x In Sheets("param").[critere_2]
If sheetExists(etab_x) = True Then
Else
Sheets.Add.Name = etab_x
With ActiveSheet.Tab
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.399975585192419
End With
'mettre le nom de l'acronyme de l'etablissement unique dans la zone de critère
Sheets("param").Range("d2") = etab_x
'faire le filtre élaboré et copié le résultat dans la plage parametre destiné
Sheets("R_MoulinetteAValider").Range("plage_debut").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
Range("critere_1"), CopyToRange:=Sheets("param").Range("receptrice"), Unique:=False
'copie des resultats du filtre élaboré dans les feuille d'établissement unique
Sheets("param").Range("i1:z" & LastLignUsedInSheet_Column("param", "i")).Copy Sheets(etab_x.value).Range("a1")
'supprimer les résultats afin d'éviter les lignes de l'établissement antérieur
Sheets("param").Range("i2:z" & LastLignUsedInSheet_Column("param", "i")) = Empty
End If
Next etab_x
Application.DisplayAlerts = True
finish = Timer
MsgBox "durée du traitement: " & finish - start & " secondes"
Exit Sub
errorhandler:
MsgBox "Erreur d'exécution, la procédure va se terminer !", vbCritical
End Sub |
