Comment accélérer l'exécution de la procédure.

**licpegpon** · 28/05/2019, 14h48

Bonjour,

La procédure ci-dessous fonctionne parfaitement cependant la boucle située de la ligne 180 à 187 est plutôt longue (je précise que dans mon cas la variable Derlig_extract = 1326.

Que puis-je faire pour accélérer le déroulement de cette procédure ? Merci par avance.

Cdlt.
Jérôme.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Recup_data_pour_STEP()
 
'Déclaration des variables
'
Dim nbr_step As Long
Dim Derlig_step As Long
Dim Derlig_extract As Long
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim y As Integer
Dim x As String
Dim Deliv_Target_Date As Variant
Dim statusBarInitial As Long
Dim ID_reseau(100)
Dim Tab_EXTRACT() As Variant
'
'Déclaration des variables relatives au check date
'
Dim check_Deliv_Target_Date As String
'
'Les fichiers "STEP.xlsm" et "Extract.xlsx" doivent être dans le même sous-dossier.
'
If MsgBox("'STEP.xlsm' and 'EXTRACT.xlsx' must be in the same subfolder (root folder)." & Chr(10) & Chr(10) & "Is that the case ?", vbYesNo, "Confirmation Request") = vbNo Then
MsgBox ("Thank you to place the two files (STEP.xlsm and extract.xlsx) in the same subfolder.")
Exit Sub
Else
End If
'
'Sablier
Application.Cursor = xlWait
'
'Affichage de toutes les colonnes y compris celles masquées
Cells.Select
Selection.EntireColumn.Hidden = False
'
'Exécution de la macro "Recuperation_Noms_sous_dossiers"
Call Recuperation_Noms_sous_dossiers
'
'Permet de ne pas avoir à cliquer sur OK à chaque fois que c'est demandé (msgbox). Ainsi la validation est automatique
Application.EnableEvents = False
 
nbr_step = 0
'
'On est dans le fichier "STEP.xlsm", onglet "FEUIL1"
'
'Recherche du numéro de la dernière ligne non vide en partant de B6 (dernier ID) --> Derlig_step
'Recherche du nombre de références ID en colonne B --> nbr_step
'
Derlig_step = Application.WorksheetFunction.CountA(Range("B:B")) + 4
MsgBox ("Derlig_step = ") & Derlig_step
nbr_step = Range("B6:B" & Derlig_step).SpecialCells(xlCellTypeVisible).Count
MsgBox ("Nbr_step =") & nbr_step
 
'Affichage dans une boite de dialogue du nombre de références ID
MsgBox ("You have " & nbr_step & " ID's references")
 
'Initialisation des compteurs (on part de la ligne 6)
i = 1
y = 6
 
'Boucle sur le nombre de références ID, nbr_step (remplissage du tableau)
statusBarInitial = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'
'Affiche pendant 1 seconde un message, cette fenêtre disparait ensuite et la procédure se poursuit
'CreateObject("Wscript.shell").Popup "IN PROGRESS :" & Chr(10) & Chr(10) & "Data recovery for all IDs in the list !!", 2, "For information", vbInformation
'
'
While i <= nbr_step
Application.StatusBar = "Calcul en cours... " & i & " / " & nbr_step
    DoEvents
 
'Activation du fichier "STEP.xlsm", on se place dans l'onglet "Feuil1"
Windows("STEP.xlsm").Activate
Sheets("Feuil1").Activate
 
'x correspond à la valeur de la cellule B6 (première valeur de la liste)
x = Range("B" & y).Value
'
'Affiche pendant 1 seconde le nom du fichier en cours de traitement, cette fenêtre disparait ensuite et la procédure se poursuit
CreateObject("Wscript.shell").Popup "PLEASE WAIT" & Chr(10) & Chr(10) & "File " & "Entry_Form_" & x & ".xlsm", 2, "For information", vbInformation
'
'Ouverture du fichier "Entry_Form_ID.....xlsm" situé dans le dossier racine auquel on rajoute le sous-dossier ID....
'Activation de l'onglet "ADD_INFOS"
 
Workbooks.Open Filename:=Dossier_racine & "\" & x & "\" & "Entry_Form_" & x & ".xlsm"
Sheets("ADD_INFOS").Activate
'
'S'il y a un message d'erreur alors aller à l'étiquette fin.
On Error GoTo fin
 
'-----------------------------------------------------------------------------
'
' Mise en mémoire de la "Delivery Target Date" du fichier "Entry_Form_ID.....xlsm".
' Celle-ci sera rapatriée dans le fichier "STEP.xlsm"
' On est toujours dans l'onglet "ADD_INFOS"
'
'-----------------------------------------------------------------------------
'
'------Deliv_Target_Date (H6)------
'
check_Deliv_Target_Date = IsDate(Range("H6").Value)
'MsgBox ("Deliv_Target_Date = ") & check_Deliv_Target_Date & Range("H6").Value
If check_Deliv_Target_Date Then
Deliv_Target_Date = Range("H6").Value
'MsgBox ("Deliv Target Date VRAI")
Else
'MsgBox ("Deliv Target Date FAUX")
Deliv_Target_Date = ""
'MsgBox ("Deliv_Target_Date = ") & Deliv_Target_Date
End If
'
'------------------------------------------------------------------------------
'
' Fin de mise en mémoire des données du fichier "Entry_Form_ID.....xlsm".
'
'------------------------------------------------------------------------------
'
'
'On active le fichier "STEP.xlsm" et on se mets dans l'onglet "Feuil1"
Windows("STEP.xlsm").Activate
Sheets("Feuil1").Activate
'
'
'On colle la valeur précédemment mise en mémoire dans le fichier "STEP.xlsm" (onglet "Feuil1")
'
'------Deliv_Target_Date------La formulation ci-dessous permet d'éviter l'inversion jour / mois
'
If IsDate(Deliv_Target_Date) Then
Range("I" & y).NumberFormat = ""
Range("I" & y).Value = CDate(Deliv_Target_Date)
Else
Range("I" & y).Value = Deliv_Target_Date
End If
'
'
y = y + 1
i = i + 1
'
'
'Fermer le fichier "Entry_Form_ID....xlsm" sans l'enregistrer (false)
Workbooks("Entry_Form_" & x & ".xlsm").Close False
 
Wend
Application.StatusBar = ""
Application.DisplayStatusBar = statusBarInitial
'
'
'Affiche pendant 1 seconde un message, cette fenêtre disparait ensuite et la procédure se poursuit
'CreateObject("Wscript.shell").Popup "Data recovery completed !!", 2, "For information", vbInformation
'
'------ ON OUVRE LE FICHIER "EXTRACT.xlsx" ET ON VA DANS L'ONGLET "owssvr" ------
'
Workbooks.Open Filename:=Dossier_racine & "\" & "extract.xlsx"
Sheets("owssvr").Activate
'
Derlig_extract = Range("A" & Rows.Count).End(xlUp).Row
MsgBox ("Derlig_extract = ") & Derlig_extract
'
'La ligne d'instruction ci-dessous suffit à elle seule pour remplir le tableau !!
'La zone mise en mémoire part de la 2ème ligne --> Range("A2") jusqu'à "derlig_extract - 1"
'Le tableau contient 23 colonnes et "derlig_extract - 1" lignes
'
Tab_EXTRACT = Range("A2").Resize(Derlig_extract - 1, 23).Value
'
'
'Fermer le fichier "Extract.xlsx" sans l'enregistrer (false)
Workbooks("Extract.xlsx").Close False
'
'
'On revient dans le fichier "STEP.xlsm" et on se mets dans l'onglet "Feuil1"
Windows("STEP.xlsm").Activate
Sheets("Feuil1").Activate
'
MsgBox ("Data storage from 'Extract.xlsx' file is complete. The repatriation of the data will begin. Please wait.")
'
'On colle les valeurs précédemment mises en mémoire
'
For j = 1 To Derlig_extract - 1
 
For k = 1 To 23
 
Cells(j + 5, k + 10) = Tab_EXTRACT(j, k)
 
Next
Next
'
'On masque les colonnes I à AJ et AL
Columns("I:AJ").Select
Selection.EntireColumn.Hidden = True
Columns("AL:AL").Select
Selection.EntireColumn.Hidden = True
'
Range("A1").Select
'
MsgBox ("Update finished !!")
'
Application.EnableEvents = True
'
'Exécution de la macro "SaveFile"
Call SaveFile
'
Application.Cursor = xlDefault
'
'Permet de sortir de la procédure et évite la gestion d'erreur (errorHandler), si la macro
's'est déroulée sans encombre.
'
Exit Sub
'
fin:
'
'Activation du fichier "STEP.xlsm", on se place dans l'onglet "Feuil1"
'
Windows("STEP.xlsm").Activate
Sheets("Feuil1").Activate
'
MsgBox ("Warning : Procedure interrupted due to error")
'
End Sub
Sub SaveFile()
  Dim Filename As String
 
  If MsgBox("Do you want to save 'STEP.xlsm' on your local drive ?", vbQuestion + vbYesNo, "Confirmation Request") = vbYes Then
    Filename = "STEP_" & Format(Date, "yyyymmdd") & "_" & Format(Time, "hhmmss") & ".xlsm"
    With Application.FileDialog(msoFileDialogSaveAs)
      .Title = "Save File as"
      .InitialFileName = Filename
      .FilterIndex = 2 ' 1 = xlsx, 2 = xlsm, 3 = xlsb
      .Show
      .Execute
    End With
  End If
End Sub

**Philippe Tulliez** · 28/05/2019, 15h15

Bonjour,
On peut charger une plage de cellules en mémoire en une seule instruction et bien entendu on fait de même pour la décharger

Tu auras toutes les explications dans ce tutoriel Utiliser les variables tableaux en VBA Excel avec une attention toute particulière aux chapitres

XIV-C. Alimenter une ListBox multicolonnes à partir d'un tableau

XIV-F. Transférer le contenu d'un tableau dans une feuille de calcul

**licpegpon** · 28/05/2019, 15h25

Merci beaucoup. J'y regarde....

**licpegpon** · 28/05/2019, 18h10

Bonjour,

J'ai remplacé les lignes 180 à 187 par l'instruction suivante supposée faire la même chose mais beaucoup rapidement (si j'ai bien compris) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range(Cells(6, 11), Cells(UBound(Tab_EXTRACT, 1), UBound(Tab_EXTRACT, 2))) = Tab_EXTRACT

Si je comprends bien la première partie (Range(Cells(6, 11)) permet de dire à partir d'où on va coller les valeurs ?
Que font les deux autres parties ?

Lorsque j'éxécute la macro en ayant fait ce remplacement seulement une partie du tableau est recopiée ? En fait seule 13 colonnes ont été "collées". Les autres colonnes sont vides ?
Cela vient du fait que je ne comprends pas à quoi correspondent les deux termes situés après (Range(Cells(6, 11))....

Pouvez-vous éclairer ma lanterne ? Merci par avance.

Cdlt.
Jérôme.

**Philippe Tulliez** · 28/05/2019, 18h32

Bonjour Jérôme,
Range("C13") et Cells(13, 3) c'est du pareil au même.

Par contre, si l'on veut utiliser la plage C2:F9
Ce sera soit

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range("C2:F9")

soit

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range(cells(2, 3), Cells(9, 6))

Attention qu'idéalement pour éviter les problèmes il est important de préciser la parentalité complète de l'objet Range (Classeur + Feuille + Cellules)

Ce serait alors pour l'affichage de l'adresse de la plage (ne pas oublier les points devant Range et devant Cells)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub toto()
 With ThisWorkbook.Worksheets("Test")
  MsgBox .Range(.Cells(2, 3), .Cells(9, 6)).Address(External:=True)
 End With
End Sub

**licpegpon** · 29/05/2019, 10h00

OK. Mais dans mon cas Range comporte 3 parties ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Range(Cells(6, 11), Cells(UBound(Tab_EXTRACT, 1), UBound(Tab_EXTRACT, 2))) = Tab_EXTRACT

La première permet de définir la cellule à partir de laquelle je vais coller les valeurs (à partir de la cellule K6).

Que font les deux autres parties ? :
Cells(UBound(Tab_EXTRACT, 1)
et
UBound(Tab_EXTRACT, 2)

Cdlt.
Jérôme.

Comment accélérer l'exécution de la procédure.

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager