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
| Function getuser()
getuser = Application.UserName
End Function
Sub createfile()
' Cette macro prépare un fichier dans lequel elle envoi les employés sélection dans la list input_box
Set wbapp = ActiveWorkbook
Set wsenvoi = ActiveSheet
Dim linktobreak As String
Dim fperm As String
Dim ws_template As String
Dim nm As Name
Dim SaveName As String
Application.DisplayAlerts = False
fperm = Range("ws_tperm")
linktobreak = wbapp.FullName
r = Range("list_input_combo").Row + 1
c = Range("list_input_combo").Column
Range("input_combo") = wsenvoi.Cells(r, c)
colstatut = Range("col_statut")
permrow = Range("permrow")
SaveName = Range("envoi_savepath") & "\" & Range("envoi_save").Value
'To sort data by supervisor
Call SortRange(fperm, Range("sort_colsup"))
If Range("input_combo") <> "" Then
ws_template = Range("ws_template").Value
ws_summary = Range("ws_summary").Value
'Première entrée
Call lockunlock(ws_template)
wbapp.Sheets(Array(ws_summary, ws_template)).Copy
Set wbcopy = ActiveWorkbook
Sheets(ws_template).Select
Sheets(ws_template).Name = wsenvoi.Cells(r, c + 6)
storefirstname = Replace(wsenvoi.Cells(r, c + 6), "'", "''")
'modification du statut
If wsenvoi.Range("statut_res") <> 1 Then
wbapp.Sheets(fperm).Cells(permrow, colstatut) = wsenvoi.Range("newstatus").Value
End If
Call deletenameandbreaklink(linktobreak)
r = r + 1
x = 1
'Loop à traver la liste
While wsenvoi.Cells(r, c) <> ""
Application.Wait (Now + TimeValue("0:00:1"))
wbapp.Activate
Range("input_combo") = wsenvoi.Cells(r, c)
permrow = Range("permrow")
If wsenvoi.Cells(r, c + 7).Value = "Yes" Then
Rows("71:82").EntireRow.Hidden = True
Else
Rows("71:82").EntireRow.Hidden = False
End If
Sheets(ws_template).Copy After:=wbcopy.Sheets(ws_summary)
Call deletenameandbreaklink(linktobreak)
newsname = wsenvoi.Cells(r, c + 6)
Sheets(ws_template).Name = newsname
If x Mod 40 = 0 Then
wbcopy.SaveAs FileName:=SaveName
wbcopy.Close
Set wbcopy = Nothing
Set wbcopy = Application.Workbooks.Open(SaveName)
End If
r = r + 1
'Copier summary
Sheets(ws_summary).Cells(wsenvoi.Range("col_copysummary").Value, 1).EntireRow.Copy
Sheets(ws_summary).Select
Cells(wsenvoi.Range("col_copysummary").Value + x, 1).Select
ActiveSheet.Paste
Cells(wsenvoi.Range("col_copysummary").Value + x, 1).Select
' Ligne pour ramener la recherche à "within Worksheet" SL
Set temp = Worksheets(1).Range("A1:A1").Find(" ", LookIn:=xlValues)
ActiveCell.EntireRow.Replace What:=storefirstname, Replacement:=Replace(newsname, "'", "''"), LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'modification du statut
If wsenvoi.Range("statut_res") <> 1 Then
wbapp.Sheets(fperm).Cells(permrow, colstatut) = wsenvoi.Range("newstatus").Value
End If
x = x + 1
Wend
'Inscription dans le log
wbapp.Activate
wsenvoi.Activate
Call logenvoi
'Protection et sauvegarde
wbcopy.Colors = wbapp.Colors
If x > 40 Then
wbcopy.Save
Else
If Val(Application.Version) < 12 Then
wbcopy.SaveAs FileName:=SaveName, FileFormat:=xlWorkbookNormal
Else
wbcopy.SaveAs FileName:=SaveName, FileFormat:=56
End If
End If
Application.Wait (Now + TimeValue("0:00:2"))
wbcopy.Close SaveChanges:=False
End If
Application.DisplayAlerts = True
End Sub
Sub createlistofemp(code_sup As Long)
'Mettre à jour les spécifications
Range("pos_sup") = code_sup
fperm = Range("ws_tperm")
csource = Range("ws_tsource_combo")
r = Range("pos_sup_firstline")
Call SortRange(fperm, Range("sort_colsup"))
'Effacer données inscrites
x = 1
While Range("list_input_combo").Offset(x, 0) <> ""
Range("list_input_combo").Offset(x, 0).ClearContents
x = x + 1
Wend
'Créer liste
Z = 1
For x = 1 To Range("pos_sup_count")
Range("input_combo") = Sheets(fperm).Cells(r + x - 1, csource)
If Range("statut_test") = True Then
Range("list_input_combo").Offset(Z, 0) = Sheets(fperm).Cells(r + x - 1, csource)
Z = Z + 1
End If
Next x
End Sub
Sub envoitous()
fsup = Range("sup_ws")
c = Range("sup_list1col")
r = 2
Call listsup
While Sheets(fsup).Cells(r, c) <> ""
Range("envoi_suppos") = Sheets(fsup).Cells(r, c)
Call createlistofemp(Range("envoi_suppos").Offset(0, 1))
Call createfile
r = r + 1
Wend
End Sub
Sub deletenameandbreaklink(linktobreak As String)
'ActiveWorkbook.BreakLink Name:=linktobreak, Type:=xlExcelLinks
'Effacer nom externe
For Each nm In ActiveWorkbook.Names
If InStr(nm.RefersTo, "[") > 0 Then
nm.Delete
End If
Next
Application.Wait (Now + TimeValue("0:00:1"))
'Briser lien vers application
ActiveWorkbook.BreakLink Name:=linktobreak, Type:=xlExcelLinks
aLinks = ActiveWorkbook.LinkSources(xlOLELinks)
If Not IsEmpty(aLinks) Then
MsgBox ("Une erreur est survenue. Le fichier préparé est erroné.")
End If
End Sub
Sub logenvoi()
'Inscription du fichier dans le log
'Mettre à jour les spécifications
Set wsenvoi = ActiveSheet
flog = Range("log_ws").Value
rlog = Range("log_lrow").Value + 1
renvoi = Range("log_id").Row
cenvoi = Range("log_id").Column
r = Range("list_input_combo").Row + 1
c = Range("list_input_combo").Column
logcount = Range("log_count")
'Loop des entrées du log
For x = 1 To logcount
test = wsenvoi.Cells(renvoi + x - 1, cenvoi)
Sheets(flog).Cells(rlog, x) = wsenvoi.Cells(renvoi + x - 1, cenvoi)
Next x
'Inscription des numéros d'employés
colempl = Range("log_colempl").Value
For x = 1 To Range("pos_sup_count")
Sheets(flog).Cells(rlog, colempl + x - 1) = wsenvoi.Cells(r + x - 1, c)
Next x
End Sub
Sub select_suppos()
If Range("envoi_suppos").Offset(0, 2) = False Then
createlistofemp (Range("envoi_suppos").Offset(0, 1).Value)
End If
End Sub
Sub select_suppos2()
If Range("envoi_suppos2").Offset(0, 2) = False Then
Call createlistofemp(Range("envoi_suppos2").Offset(0, 1).Value)
End If
End Sub
Sub lockunlock(sname As String)
'Barrer toutes les cellules
Sheets(sname).Activate
Sheets(sname).Cells.Locked = True
Sheets(sname).Cells(1, 1).Select
'Débarrer cellules requises
x = 1
While Range("unlock_liste_noms").Offset(x, 0) <> ""
If Range("unlock_liste_noms").Offset(x, 1) = 1 Then
nametounlock = Range("unlock_liste_noms").Offset(x, 0)
ActiveSheet.Range(nametounlock).Select
Selection.Locked = False
End If
x = x + 1
Wend
If ActiveSheet.Range("Res_Strat") <> "" Then
ActiveSheet.Range("unlock_strat_res").Select
Selection.Locked = True
End If
Sheets(sname).Cells(1, 1).Select
Sheets(sname).Protect
End Sub |
14/12/2011, 15h48
Probleme Protection Cellules
00
