Optimisation code d'import de données

Version imprimable

Bonjour,

Je jette une bouteille à la mer... :calim2:

J'ai écrit une macro VBA-E (fonctionnelle).
Pour autant je me pose la question sur son optimisation.

La macro réalise l'import de data issues de différents classeurs Excel. (fermés les classeurs)

Le temps d'import pour 1 fichier oscille entre 33 secondes et 58 secondes (voir dans ses mauvais jours à 1min)
Si on multiplie ce temps par (x) fichiers, ah bah ça peut monter très vite et le temps paraît très longgggg pour l'utilisateur malgré tout le soin apporté :-( (15 fichiers 22 minutes par exemple) 8O 8O 8O

Je ne parviens pas à trouver une solution adéquate (si ce n'est passer par des Array peut-être ou du xml)

Ci-dessous le code commenté, si une bonne âme veut bien venir à ma rescousse je ne la remercierais jamais de trop.

Code concerné : (283 lignes)

Code:

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

11/01/2018, 21h28
dyalee

Complément

Si besoin d'informations complémentaires n'hésitez pas à me demander :calim2:
11/01/2018, 23h37
patricktoulon

re

re

oui j'avoue honnetement que adob.connection je ne sais pas m'en servir et pour cause (je ne l'utilise jamais) c'est pas mon reillon

il faudrait que tu te rapproche de membre dyhortographie qui est bien callé en la matiere

mon reillon c'est plutot le rapatriment de données WEB dans excel
12/01/2018, 00h59
dyalee

Citation:

Envoyé par patricktoulon

re

oui j'avoue honnetement que adob.connection je ne sais pas m'en servir et pour cause (je ne l'utilise jamais) c'est pas mon reillon

il faudrait que tu te rapproche de membre dyhortographie qui est bien callé en la matiere

mon reillon c'est plutot le rapatriment de données WEB dans excel

Merci encore une fois d'y avoir jeter un œil, je vais essayer de contacter le membre que tu m'as suggéré :)

:)
12/01/2018, 01h09
dyalee

Si @dysorthographie passe par là :)
12/01/2018, 07h27
Invité

Bonjour dyalee et Patrick,

Tu vas définir ton objet de connection comme public dans un module stand.

Dans ta procédure principale tu vas effectuer une connexion permanente pendant tout le traitement sur ThisWorkbook.FullName!

Et dans ta requête tu fais une jointure externe vers ton classeur!

Tu peux le cas échéant updater ThisWorkbook!

Code:

Select * from [Feuil2$] in 'C:\MyRepertoire2\Classeur1.xlsm' 'Excel 12.0;HDR=Yes')

Reste dispo.

https://mon-partage.fr/f/LoCWKVjq/
12/01/2018, 08h37
pijaku
Bonjour,

En plus de la remarque de dysortho, donne nous les codes des fonctions :
Code:

1 2 3 4 5 WasteTime MefTableControlCellValue RefreshAllDataConnections NotConcernedCondition HideMoreCost
Et comme on te l'a dit sur un autre forum, avant de privilégier l'esthétique, teste l'efficacité.
Donc, pour l'instant, met en commentaires tout ce qui n'est qu'esthétique : Spinner, Shapes, etc...

Si tu obtiens un résultat meilleur, il sera temps de penser à les remettre... ou non...

1 pièce(s) jointe(s)

Bonjour pijaku, dysorthographie et Patrick

Merci déjà (la base) même beaucoup à vous tous...

@pikaku : Justement j'étais en train de mesurer les performances de la macro d'import avec ses call avant d'attaquer la tâche avec la connexion comme suggéré par @dysorthographie

Je vais commencer par rendre compte du processus d'élaboration pour tenter de mettre à votre disposition toutes les informations relatives à ce module.
Pièce jointe 341970

Pour la légende et pour en revenir aux performances :

Les blocs verts sont les appels pour lesquels je juge la performance acceptable (mais perfectible)
Les blocs oranges sont les appels pour lesquels je juge la performance limite
Les blocs rouges sont les appels pour lesquels je juge la performance laborieuse

Ensuite les codes associés :
WasteTime

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub WasteTime(Finish As Long)
    Dim GetTickCount As Integer
    Dim NowTick As Long
    Dim EndTick As Long
 
    GetTickCount = 0
    EndTick = GetTickCount + (Finish * 1000)
 
       Do
 
           NowTick = GetTickCount
           GetTickCount = GetTickCount + 1
           DoEvents
 
           Loop Until NowTick >= EndTick
End Sub

MefTable

Code:

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
Option Explicit
Sub MefTable()
Dim i As Integer
Dim m_ING_derniereLigne As Long
Dim plage1
Dim plage2
Dim plage3
'+--------------+
    For i = 1 To Sheets.Count
        m_ING_derniereLigne = Sheets(i).Cells(Rows.Count, "E").End(xlUp).Row
        If Sheets(i).Name Like "WS*" And Sheets(i).Visible And Sheets(i).Name <> "WS-Consolidate" And Sheets(i).Visible Then
            On Error Resume Next
            Sheets(i).Range("L11:L" & m_ING_derniereLigne).NumberFormat = "0%"
            Sheets(i).Range("O11:O" & m_ING_derniereLigne).NumberFormat = "0%"
            Sheets(i).Range("L11:L" & m_ING_derniereLigne).Value = Sheets(i).Range("L11:L" & m_ING_derniereLigne).Value
            Sheets(i).Range("O11:O" & m_ING_derniereLigne).Value = Sheets(i).Range("O11:O" & m_ING_derniereLigne).Value
'+--------------+
' (\ /)
' (. .) ? ~< Code à optimiser>
'c(")(")
'+--------------+
            Sheets(i).Range("P11:P" & m_ING_derniereLigne).NumberFormat = "#,##0.00 $"
            Sheets(i).Range("N11:N" & m_ING_derniereLigne).NumberFormat = "dd-mmm-yy;@"
            Sheets(i).Range("N11:N" & m_ING_derniereLigne).HorizontalAlignment = xlCenter
            Sheets(i).Range("N11:N" & m_ING_derniereLigne).VerticalAlignment = xlCenter
'+--------------+
' (\ /)
' (. .) ? ~<>
'c(")(")
'+--------------+
            'plage1 = "J11:K" & m_ING_derniereLigne
            'plage2 = "M11:M" & m_ING_derniereLigne
            'plage3 = "F11:G" & m_ING_derniereLigne
'+--------------+
            On Error GoTo 0
        End If
    Next
End Sub

ControlCellValue

Code:

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
Option Explicit
Sub ControlCellValue()
    Dim m_ING_derniereLigne
    Dim Plage As Range
    Dim x
    Dim i
    Dim a As Worksheet
    Dim c As Range
    Dim ThisRow As Single
    Dim Range As Range
    Dim Feuille As Worksheet
 
Application.EnableEvents = False
 
Dim TaListe1 As Variant
Dim TaListe2 As Variant
TaListe1 = Sheets("BDD").Range("Liste_Action_Plan_1").Value
TaListe2 = Sheets("BDD").Range("Liste_Full_IDD").Value
 
       For Each Feuille In ActiveWorkbook.Worksheets
 
            If Feuille.Name Like "WS*" And Feuille.Visible And Feuille.Name <> "WS-Consolidate" Then
                   m_ING_derniereLigne = Feuille.Cells(Rows.Count, "H").End(xlUp).Row
 
                  Set Feuille = Worksheets(Feuille.Name)
                  Set Plage = Feuille.Range("H11:H" & m_ING_derniereLigne)
 
                For Each c In Plage
                    If Feuille.Name Like "WS*" And Feuille.Visible And Feuille.Name <> "WS-Consolidate" Then
                         m_ING_derniereLigne = Feuille.Cells(Rows.Count, "H").End(xlUp).Row
                         x = c.Value
                        ThisRow = c.Row
                            If x = "Not concerned" Then
                                Feuille.Range("L" & ThisRow).Value = "Not concerned"
                                Feuille.Range("O" & ThisRow).Value = "Not concerned"
                            ElseIf x = "No Impact" Then
                                Feuille.Range("L" & ThisRow).Value = 1
                                Feuille.Range("O" & ThisRow).Value = 1
                            ElseIf x = "-" Then
                                Feuille.Range("H" & ThisRow).Value = "Not concerned"
                                Feuille.Range("L" & ThisRow).Value = "Not concerned"
                                Feuille.Range("O" & ThisRow).Value = "Not concerned"
                            ElseIf x <> "" Then
                                Select Case True
                                    Case Feuille.Range("L" & ThisRow) = "":
                                        Feuille.Range("L" & ThisRow).ClearContents
                                        Feuille.Range("L" & ThisRow).Value = TaListe1
                                        Feuille.Range("L" & ThisRow).Value = 0
                                    Case Feuille.Range("O" & ThisRow) = "":
                                        Feuille.Range("O" & ThisRow).ClearContents
                                        Feuille.Range("O" & ThisRow).Value = TaListe2
                                        Feuille.Range("O" & ThisRow).Value = 0
                                    Case Else
                                        Feuille.Range("L" & ThisRow).Value = Feuille.Range("L" & ThisRow).Value
                                        Feuille.Range("O" & ThisRow).Value = Feuille.Range("O" & ThisRow).Value
                                End Select
                            End If
                        End If
                    Next
                End If
 
 
       Next
 
Set Plage = Nothing
Set Feuille = Nothing
Application.EnableEvents = True
End Sub

RefreshAllDataConnections

Code:

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
Sub RefreshAllDataConnections()
      Dim objConnection
      Dim bBackground
      Dim x
      Dim dtmStart As Date, lngA As Long
      On Error Resume Next
 
10        For Each objConnection In ThisWorkbook.Connections
 
 
20            If objConnection.Name <> "Requête*-*Directory" And _
                        objConnection.Name <> "Requête*-*DirectoryData" Then
                  'Get current background-refresh value
30                bBackground = objConnection.OLEDBConnection.BackgroundQuery
 
                  'Temporarily disable background-refresh
40                objConnection.OLEDBConnection.BackgroundQuery = False
 
                  'Refresh this connection
50                objConnection.Refresh
60                Application.CalculateUntilAsyncQueriesDone
                  'Application.CalculateFullRebuild
                  'Application.CalculateUntilAsyncQueriesDone
 
                  'Set background-refresh value back to original value
70                objConnection.OLEDBConnection.BackgroundQuery = bBackground
80            End If
90        Next
 
91          Call ControlCellValue
WasteTime (20)
110       Call AllWorkbookPivots
WasteTime (20)
122       Call ConditionalFormattingShapes 'acceptable
WasteTime (20)
120       Call NotConcernedClient
WasteTime (10)
121       Call HideMoreCost
WasteTime (10)
 
End Sub

AllWorkbookPivot

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub AllWorkbookPivots()
Dim pt As PivotTable
Dim ws As Worksheet
 
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name = "Data_cost" Or ws.Name = "BddRating" Then
            For Each pt In ws.PivotTables
                        pt.RefreshTable
                        WasteTime (4)
 
            Next pt
        End If
    Next ws
End Sub

NotConcernedCondition

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Sub NotConcernedCondition()
Dim O As Worksheet
Dim Nc As String
Dim Na As String
'+--------------+
Set O = ActiveSheet
Nc = "Dashboard"
Na = "DashboardAdmin"
'+--------------+
     With ActiveSheet
        If O.Name = Nc Then
            Call NotConcernedClient
        End If
        If O.Name = Na Then
            Call NotConcernedAdmin
        End If
    End With
End Sub

La macro HideMoreCost va être supprimée donc on fait l'impasse

J'avais déjà réalisé les tests sans la cosmétique.
Cela n'a pas d'impacts majeurs, pour autant je veux bien reproduire l'expérience :)

Dernière précision il y'a du PowerQuery derrière.
Et le moteur de calcul a été conçu pour fonctionner avec une version Excel 2010 32 bit ou ultérieure

J'espère avoir été factuelle.

Merci encore (beaucoup)

NB : Je suis boulimique de conseils, d'observations et de critiques constructives, aussi n'hésitez pas à mettre en relief ce que je n'ai pas fait de manière adéquate ect, etc...

1- Ta fonction WasteTime est-elle systématiquement requise?
Je veux bien que l'on place par ci par là des boucles d'attente, mais il faut que celles-ci soient justifiées.
A vérifier car, rien qu'avec ça, tu perds plus de 5 secondes.
De plus, durant ces 5 secondes, tu fais mouliner ton processeur (à cause du DoEvents en boucle) qui, à force, doit s’essouffler...

2- Ta procédure ControlCellValue est déclenchée 2 fois.
La première dans le "main", la seconde dans ton RefreshAllDataConnections.
Est-ce bien utile?
Et, en effet, tu as raison de la qualifier en "rouge".
Tu boucles sur les cellules d'une plage qui, si elle est importante, va considérablement augmenter le temps d'exécution.
Passe l'intégralité de ta feuille dans une variable tableau et exécute tes contrôles et modifications sur cette variable.
Tu n'auras qu'à la repasser dans ta feuille après.

Un autre détail dans cette procédure :
Code:

1 2 3 4 5 6 7 8 If Feuille.Name Like "WS*" And Feuille.Visible And Feuille.Name <> "WS-Consolidate" Then 'Plus Haut m_ING_derniereLigne = Feuille.Cells(Rows.Count, "H").End(xlUp).Row Set Feuille = Worksheets(Feuille.Name) Set Plage = Feuille.Range("H11:H" & m_ING_derniereLigne) For Each c In Plage If Feuille.Name Like "WS*" And Feuille.Visible And Feuille.Name <> "WS-Consolidate" Then 'POURQUOI????? Cf Plus Haut
EDIT : MEF :
remplacer (par exemple) :
Code:

1 2 3 4 Sheets(i).Range("L11:L" & m_ING_derniereLigne).NumberFormat = "0%" Sheets(i).Range("O11:O" & m_ING_derniereLigne).NumberFormat = "0%" Sheets(i).Range("L11:L" & m_ING_derniereLigne).Value = Sheets(i).Range("L11:L" & m_ING_derniereLigne).Value Sheets(i).Range("O11:O" & m_ING_derniereLigne).Value = Sheets(i).Range("O11:O" & m_ING_derniereLigne).Value
Par :
Code:

1 2 Sheets(i).Range("L11:O" & m_ING_derniereLigne).NumberFormat = "0%" Sheets(i).Range("L11:O" & m_ING_derniereLigne).Value = Sheets(i).Range("L11:O" & m_ING_derniereLigne).Value

12/01/2018, 16h15
dyalee

1 pièce(s) jointe(s)
@Pijaku :

Réponse N°1 - Requise, oh que non, pour dire vrai, cela venait, artificiellement temporiser l'enchaînement des actions.
Notamment lors de la mise à jour des requêtes PowerQuery qui se rafraîchissent non pas par séquencement mais de manière tout à fait aléatoire générant une surchage.
le Wastetime permet donc de définir le délai d’attente entre chaque update (enfin le simule) mais cette solution n'était que temporaire le temps que je refactorise le code.

J'étais partie dans l'idée de simuler du multithread (chose tout à fait possible) pour gérer l'execution simultanée. (sur le papier c'est beau mais dans les faits...)

Enfin Wastetime me permet aussi de ne pas vraiment suspendre toutes les tâches comme pour un Application.Ontime

En conclusion : C'est une rustine 8O

Réponse N°2 - Oui et Non
Le contrôle des cellules est requis après action onclic sur bouton "Refresh Data" ou durant la phase d'import avant rafraîchissement des données
Selon l'architecture suivante :
Pièce jointe 342088

De mémoire je l'avais d'abord mis dans Actualiser les données en l'appelant selon la condition (SI EST CLIENT OU SI EST MASTER)
Mais cela m'avait fait défaut.

Réponse autre détail Macro ControlCellValue :
Résiduel de modification je crois → à corriger

Je vais tenter variables tableaux (Arrays)
Faut que je m'y exerce, je ne maîtrise pas (encore) sur VBA

Peux-tu me dire si j'ai faux :
1 - Transfèrer les champs dans un Array.
2 - Transférer le Array dans les champs + (boucle ?)

Réponse N°3 - MEF
Si j'applique Sheets(i).Range("L11:O" [...])

Alors Je sélectionne la plage allant de L à O incluant donc colonne M & N
Si j'utilise un "Union" ? je suis dans l'erreur ?

Pseudo code :
```
Variable i → Définir i comme un entier

Determiné Plage1 (= à) Plage(Feuille(i).Cellule(11,12),Feuille(i).Cellule(derniereligne, 12)
Determiné Plage2 (= à) Plage(Feuille(i).Cellule(11,15),Feuille(i).Cellule(derniereligne, 15)
 
Avec feuille(i)
	.Union(Plage1, Plage2).FormatNumerique = "0%"
	.Union(Plage1, Plage2).Valeur = .Union(Plage1,Plage2).Valeur
Fin Avec
```
Point trop de politesse donc merci c'est cool de pouvoir me confronter à vos observations.
12/01/2018, 16h24
pijaku

Point 1 : à toi de ne conserver que les WasteTime utiles.
Point 2 : Un Array fonctionne de la même manière qu'une plage de cellules.
En une ligne tu charges la plage dans ton array :
MyArr = Plage.Value
Idem pour repasser tes valeurs dans la feuille.
Il y a de nombreux tutos sur ce site et ailleurs à ce sujet.
Point 3 : une erreur de lecture de ma part. Laisse tel quel.

Bonjour,

A la suite des différentes réponses et du problème rencontré (optimisation de temps d'exécution), il y a quelques petites améliorations qui lors de grosses exécutions peuvent avoir de l'importance.

Comme l'a suggéré pijaku, passer l'intégralité des feuilles dans des variables tableau permet d'accélérer le code. Dans la même optique, stocker les feuilles et les range dans des variables permet également d'accélérer les temps d'exécution (imperceptible sur de petites exécutions, mais lorsque l'on me parle de 22 minutes, ça peut avoir son intérêt) (je pense notamment qu'il serait intéressant de stocker
Code:

1 2 Sheets(i)
et
Code:

1 2 3 .Range("L11:O" & m_ING_derniereLigne) .Range("L11:O" & m_ING_derniereLigne)
ainsi que les
Code:

1 2 3 4 Feuille.Range("O" & ThisRow) Feuille.Range("L" & ThisRow) Feuille.Range("H" & ThisRow)
Ensuite, je te conseille également d'ajouter d'encapsuler ta procédure d'appel initiale par
Code:

1 2 3 4 5 6 7 8 9 Application.ScreenUpdating = False Application.Calculation = xlCalculationManual 'Le code de ta procédure d'appel à mettre ici Application.Calculation = xlCalculationAutomatic Application.Calculate Application.ScreenUpdating = True

12/01/2018, 19h31
dyalee

Oui 22 minutes 8O :weird: ... surtout quand on sait que 10 secondes est le niveau maximum de tolérance, j'imagine l'utilisateur devant son écran qui doit attendre 1mn42 environ pour 1 fichier :roll:

Je suis actuellement dessus, merci pour ces précieux conseils.
J'essaye de refactoriser le code au mieux en suivant les différentes pistes listées jusqu'ici.
Je vais également voir du côté des requêtes PowerQuery.
J'ai listé les tâches comme suit en fonction des portions de codes les plus coûteuses ou qui sont (semblent être) à l'origine du défaut de performance

Impacts majeurs :
Optimisation de ControlCellValue
Optimisation de RefreshAllDataConnections
Gestion de la connexion aux classeurs sources
Gestion du Wastetime (temporisation) qui essouffle le processeur
Impacts medium :
Optimisation AllWorkbookPivots

Impacts mineurs :
Optimisation MefTable
Optimisation ConditionalFormattingShapes

Coucou tout le monde,

J'ai fini par effectué une refonte complète.
Je n'ai pas encore commencé les travaux d’import de données.

Avant la collecte des données j'ai préféré me pencher sur le moteur de calcul et l'écran de vue d'ensemble.
Mais aussi prendre le temps de me documenter sur Vba.

Bref, j'ai donc à la lumière de vos conseils révisés les modules (qui n'était ni fait ni à faire)

Je voudrais aujourd'hui avoir des suggestions, à savoir, si le code ci-dessous pourrait être davantage optimisé, surtout sur le principe de modification des données dans un tableau VBA

Le temps d’exécution = 0,125 secondes (ce qui est beaucoup trop si nous vérifions le résultat en se basant sur un autre ordre de grandeur de données) (avant la refactorisation j'étais à 5 scd)
NB : En ajoutant un ElseIf je suis passée à 0,39 :calim2:

Il s'agit du code ControlCellValue pour l'exemple

Code:

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
Option Base 1
Sub ControlCellValue()
    Dim x, i, y As Integer
    Dim f As Worksheet
    Dim LastRow
    Dim Source
    Dim ListItems, ListeValue
    Dim VarListI, VarListV
    Dim MyVar1, MyVar2
    Dim Tablo1, Tablo2
    Dim Start As Single
 
    Start = Timer
With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayStatusBar = False
    .Calculation = xlCalculationManual
End With
 
 
Source = Array("WS1", "WS2", "WS3", "WS4", "WS5", "WS6")
With Sheets("Parameter")
    ListItems = .Range("B13:B18").Value
    ListValue = .Range("B37:B44").Value
    VarListI = Array(ListItems(1, 1), ListItems(5, 1), ListItems(6, 1))
    VarListV = Array(ListValue(1, 1), ListValue(7, 1), ListValue(8, 1))
End With
 
       For i = 1 To 6
        Set f = Worksheets(Cible(i))
           With f
            LastRow = .Range("J10000").End(xlUp).Row
            Tablo1 = .Range("J2:K" & LastRow)
            Tablo2 = .Range("M2:M" & LastRow)
                For x = 1 To UBound(Tablo1)
                    Tablo1(x, 2) = Tablo2(x, 1)
                Next
                For y = 1 To LastRow - 1
                 MyVar1 = Tablo1(y, 1)
                 MyVar2 = Tablo1(y, 2)
                    If Not IsEmpty(MyVar) Then
                        If (MyVar1 = VarListI(2) And MyVar2 <> VarListI(2)) Or MyVar1 = "-" Then
                                 MyVar1 = VarListI(2)
                                 MyVar2 = VarListV(3)
                            ElseIf (MyVar1 <> VarListI(2) And MyVar1 <> "") And MyVar2 = VarListI(2) Then
                                MyVar1 = MyVar1
                                MyVar2 = VarListV(1)
                            ElseIf MyVar1 = "" Or MyVar1 = VarListI(3) Then
                                 MyVar1 = VarListI(3)
                                 MyVar2 = VarListV(1)
                            ElseIf MyVar1 = VarListI(1) Then
                                 MyVar2 = VarListV(2)
                            ElseIf MyVar1 <> "" And (MyVar1 <> VarListI(1) Or MyVar1 <> VarListI(2)) And MyVar2 = "" Then
                                MyVar2 = VarListV(1)
                            Else
                                MyVar1 = MyVar1
                                MyVar2 = MyVar2
                        End If
                    End If
                Tablo1(y, 1) = MyVar1
                Tablo1(y, 2) = MyVar2
                Next
                 .[J2].Resize(UBound(Tablo1, 1)) = Application.Index(Tablo1, , 1)
                 .[M2].Resize(UBound(Tablo1, 1)) = Application.Index(Tablo1, , 2)
 
            End With
        Next i
 
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayStatusBar = True
    .Calculation = xlCalculationAutomatic
End With
 
MsgBox "durée du traitement: " & Timer - Start & " secondes"
 
End Sub

Merci

26/01/2018, 21h26
parmi

Bonjour,

Petite erreur ici ?

Code:

If Not IsEmpty(MyVar) Then

Je ne vois pas de déclaration ni d'initialisation de cette variable (?)

Bonsoir Parmi,

Oui en effet :)

La portion corrigée

Code:

1
2
3
4
5
For y = 1 To LastRow - 1
                 MyVar = Tablo1
                 MyVar1 = Tablo1(y, 1)
                 MyVar2 = Tablo1(y, 2)
                    If Not IsEmpty(MyVar) Then