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
273
274
275
276
277
278
279
280
281
282
283
| Sub Import(control As IRibbonControl)
10 On Error GoTo Erreurs
Dim NameOfThisWorkbook
Dim FSO As Object
Dim m_ING_derniereLigne As Long
Dim m_STR_nomFichierSaveAs As String
Dim chemin As String
Dim x
Dim type1 As String
Dim Source As ADODB.Connection
Dim Rst As ADODB.Recordset
Dim ADOCommand As ADODB.Command
Dim Counter As Integer
Dim Fin As Integer
Dim Fichier$, Cellule$, Feuille As Worksheet
Dim Path$, Folder$
Dim Plage(), i&, l&
Dim Pays As String 'Ajout LAR 09012018
'+--------------+
' (\ /)
' (. .) ? ~<Désolée le nommage des variables c'est du n'imp' pas eu le temps de faire propre ^^>
'c(")(")
'+--------------+
'+--------------+
20 Plage = Array("E11:R32")
'+--------------+
'+--------------+
' (\ /)
' (. .) ? ~<' Initialisation pour le loader : Ici nous cherchons à connaître le nombre de fichier que contient le dossier.
' Ceci aura pour but d'alimenter le [Running__Task].value (Running task correspond à une cellule nommée dans la feuille LoaderParam)
' Cette action fait appel à une fonction nommée ScanFolder (module : Enable_mdlScanFolder)>
'c(")(")
'+--------------+
30 Path = ActiveWorkbook.Path
40 type1 = "xlsm"
50 x = Application.Run("ScanFolder", Path, type1)
60 Fin = (x * 2) + 2
70 Counter = 0
71 ShowCursor (False)
72 Dashboard.Select
On Error Resume Next
80 ActiveSheet.Shapes("progress_task").Visible = True
90 [Running__Task].Value = "processing, please wait... " '& Format(Counter / Fin, "0%")
'+--------------+
' (\ /)
' (. .) ? ~<>
'c(")(")
'+--------------+
'+--------------+
' (\ /)
' (. .) ? ~<>
'c(")(")
'+--------------+
140 Spinner.EchoErrors = True
150 If Spinner.Running Then Exit Sub
160 Spinner.FadeIn PixelBuddhaSpinner:=[Spinner__Number], Duration:=3000, Disable:=CTRLBreak, Position:=ApplicationCenter, WaitForDuration:=3000
'+--------------+
Dim lngTask As Long
170 For lngTask = 1 To 1
180 Counter = Counter + 1
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°1 : Suppression conditionnelle de toutes les données présentes dans tous les feuilles WS* du classeur
' SI le nom de la feuille est WS*
' ET QUE la feuille est visible
' ET QUE la feuille n'est pas "WS-Consolidate"
' ALORS supprime la plage E11 à R dernière ligne
' Divers : Gestion du loader >>> incrémentation de +1 au compteur>
'c(")(")
'+--------------+
100 With Application
101 .ScreenUpdating = False
102 .EnableEvents = False
110 .DisplayFormulaBar = False
120 .DisplayAlerts = False
130 End With
190 For i = 1 To Sheets.Count
200 If Sheets(i).Name Like "WS*" And Sheets(i).Visible And Sheets(i).Name <> "WS-Consolidate" Then
210 m_ING_derniereLigne = Sheets(i).Cells(Rows.Count, "E").End(xlUp).Row
220 Sheets(i).Range("E11:R" & m_ING_derniereLigne).ClearContents
230 End If
240 Next
241 With Application
242 .ScreenUpdating = True
243 .EnableEvents = True
244 End With
'+--------------+
250 Counter = Counter + 1
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°2 : On recherche dans le répertoire du fichier Master la présence d'autres classeurs <> de Master.Name
' et qui correspond au format souhaité
' SI Vrai
' ALORS Création de la connexion ADODB
' Divers : Gestion du loader >>> incrémentation de +1 au compteur>
'c(")(")
'+--------------+
270 Fichier = Dir(ThisWorkbook.Path & "\*.xlsm")
280 Do While Fichier <> ""
281 With Application
282 .ScreenUpdating = False
283 .EnableEvents = False
284 End With
290 If Fichier <> ThisWorkbook.Name Then
300 Set Source = New ADODB.Connection
310 Source.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & ThisWorkbook.Path _
& "\" & Fichier & ";Extended Properties=""Excel 12.0;HDR=no;"";"
'+--------------+
320 Counter = Counter + 1
330 [Running__Task].Value = "processing, please wait... " & Format(Counter / Fin, "0%")
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°3 : Pour chaque feuille du classeur source :
' SI le nom de la feuille commence par "W"
' ET QUE la feuille est visible
' ET QUE la feuille n'est pas "WS-Consolidate"
' ALORS je récupère la dernière ligne>
'c(")(")
'+--------------+
340 For Each Feuille In ActiveWorkbook.Worksheets
350 If Left(Feuille.Name, 1) = "W" And Feuille.Visible And Feuille.Name <> "WS-Consolidate" Then
360 l = Feuille.Cells(Rows.Count, "E").End(xlUp).Row
370 ActiveSheet.Shapes("progress_task").Visible = True
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°4 : Pour chaque feuille du classeur source :
' SI le nom de la feuille commence par la lettre "W"
' ET que la feuille est visible
' ALORS je récupère la dernière ligne
' Note : La variable (i) est utilisé SI il existe plusieurs plage ce qui n'est pas le cas ici donc i = 0>
'c(")(")
'+--------------+
380 i = 0
390 Cellule = Plage(i)
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°5 : Pour chaque feuille du classeur source :
' 400 - 440 >>> Requête SQL "Client" vers "Master" dans la limite de la plage déclarée dans la variable Cellule
' 450 - 480 >>> Prépare le recordset de données pour les coller depuis le "Client" vers le "Master"
' Copy les données dans la Feuille correspondante dans la limite de la cellule E11 à R(x)(où x vaut la dernière ligne du tableau)
' 490 >>> Repositionne toi sur la cellule E11 à la fin de l'action
' 500 >>> Fermer
' 520 >>> Passer au fichier suivant automatiquement SI il en existe
' 530 - 540 >>> Divers : Gestion du Loader >>> incrémentation de +1 au compteur>
'c(")(")
'+--------------+
400 Set ADOCommand = New ADODB.Command
410 With ADOCommand
420 .ActiveConnection = Source
430 .CommandText = "SELECT * FROM [" & Feuille.Name & "$" & Cellule & "]"
440 End With
'+--------------+
'+--------------+
450 Set Rst = Source.Execute("[" & Feuille.Name & "$" & Cellule & "]")
460 With Feuille
470 .Range("E11:R" & l).CopyFromRecordset Rst
480 End With
'+--------------+
'+--------------+
490 Cells(11, 5).Activate
500 Rst.Close
510 End If
520 Next
'+--------------+
'+--------------+
530 Counter = Counter + 1
540 [Running__Task].Value = "processing, please wait... " & Format(Counter / Fin, "0%")
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°6 : On ferme tout et on vide>
'c(")(")
'+--------------+
550 Source.Close
560 Set Source = Nothing
570 Set Rst = Nothing
580 Set ADOCommand = Nothing
'+--------------+
' (\ /)
' (. .) ? ~<' Action N°7 : On traite "enregistrement sous" du classeur
' Enregistrement du classeur
' ActiveWorkbook.RefreshAll>
'c(")(")
'+--------------+
'Resume Next
WasteTime (20)
590 Call MefTable
WasteTime (20)
591 Call ControlCellValue
WasteTime (20)
600 Call RefreshAllDataConnections 'Rafraichit correctement la requête wsmerge PQ
WasteTime (20)
602 Call NotConcernedCondition
WasteTime (20)
603 Call HideMoreCost
WasteTime (20)
'On Error GoTo 0
'+--------------+
'+--------------+
With Sheets("Parameter").ListObjects("ParamCountry")
Pays = Application.VLookup(Left(Fichier, 3), [ParamCountry], 2, False)
Worksheets("Dashboard").Shapes("NomPays").Visible = True
Worksheets("Dashboard").Range("Q8").Value = Pays
End With
610 m_STR_nomFichierSaveAs = Format(Now, "hhmmss") & "-" & Day(Date) _
& "-" & Month(Date) & "-" & Year(Date) & "_" & "Cardiff_Gap_Analysis" & "_" & Pays & ".xlsm"
620 Path = ActiveWorkbook.Path
630 Folder = "Cardiff"
640 chemin = Path & "\" & Folder & "\" & m_STR_nomFichierSaveAs
'+--------------+
'+--------------+
650 Set FSO = CreateObject("Scripting.FileSystemObject")
660 If Not FSO.FolderExists(Path & "\" & Folder) Then
670 FSO.CreateFolder (Path & "\" & Folder)
680 End If
'+--------------+
'+--------------+
690 ActiveSheet.Shapes("progress_task").Visible = False
'+--------------+
'+--------------+
700 ActiveWorkbook.SaveCopyAs chemin
710 End If
'+--------------+
720 Fichier = Dir
'+--------------+
760 With Application
770 .ScreenUpdating = True
780 .EnableEvents = True
790 .DisplayAlerts = True
800 .DisplayScrollBars = True
810 .DisplayFormulaBar = False
820 .CutCopyMode = False
830 End With
WasteTime (10)
730 Loop
740 Next lngTask
'+--------------+
750 Counter = Counter + 1
'+--------------+
'+--------------+
'+--------------+
840 ActiveSheet.Shapes("progress_task").Visible = True
850 [Running__Task].Value = "complete, fading out..."
860 WasteTime (5)
870 [Running__Task].Value = "task complete"
880 WasteTime (5)
890 ActiveSheet.Shapes("progress_task").Visible = False
900 If Spinner.Running Then Spinner.FadeOut Duration:=3000
901 ShowCursor (True)
'+--------------+
'+--------------+
910 MsgBox "All files have been processed" & Chr(13) & "File's location: " & Folder, vbOK + vbInformation, "Task Completed"
'+--------------+
' (\ /)
' (. .) ? ~<'Gestion des erreurs>
'c(")(")
'+--------------+
Sortie:
920 Exit Sub
'+--------------+
Erreurs:
930 'If Err.Number = 1004 Or Err.Number = 400 Then
On Error Resume Next
940 ActiveSheet.Shapes("progress_task").Visible = True
950 [Running__Task].Value = "An error occured..."
On Error GoTo 0
MsgBox "Error: (" & Err.Number & ") " & Err.Description, vbCritical
'MsgBox "Extract data task aborted by user", vbOKOnly + vbInformation, "Cardiff Tool"
'+--------------+
On Error Resume Next
960 Dashboard.Shapes("progress_task").Visible = False
On Error GoTo 0
970 If Spinner.Running Then Spinner.FadeOut Duration:=3000
990 Resume Sortie
1000 'End If
'+--------------+
End Sub |
Optimisation code d'import de données
Répondre avec citation
Partager