Optimisation d'une boucle

**Gladiator75** · 30/03/2022, 11h29

Bonjour à toutes et tous,

J'ai un code qui fonctionne mais qui a un problème d'optimisation car cela prend beaucoup trop de temps environ 7 minutes. Je sais où se situe le problème puisque c'est lorsqu'il effectue la boucle sur environ 1700 lignes permettant de copier des données d'un classeur sur un autre classeur. Malheureusement pour des raisons de protections des données, je ne peux mettre les fichiers utilisés en annexe donc j'espère que vous pourrez m'aguiller sur comment améliorer cette partie de code (nul doute que plein d'autres choses pourraient être améliorées mais puisqu'il fonctionne

).

Peut-être avec l'utilisation de tableaux mais j'ai un peu de peine avec leurs compréhensions

.

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
Sub A_Optimiser()
 
'On définit les variables
Set FS = ActiveWorkbook
Set SS0 = FS.Worksheets("donnees suivi DE")
 
LastRowSS = SS0.Range("A" & Rows.Count).End(xlUp).Row
 
 
'On met en ordre les colonnes selon les désirs de BPO
    Columns("C:C").Cut
    Columns("B:B").Insert Shift:=xlToRight
    Columns("D:D").Cut
    Columns("C:C").Insert Shift:=xlToRight
    Columns("M:M").Cut
    Columns("D:D").Insert Shift:=xlToRight
    Columns("H:H").Cut
    Columns("G:G").Insert Shift:=xlToRight
    Columns("M:M").Cut
    Columns("F:F").Insert Shift:=xlToRight
 
'On insert 2 colonnes
    Range("H1").Resize(, 2).EntireColumn.Insert Shift:=xlToRight
 
 
'Ouvrir le fichier "Rapport_"
    Workbooks.Open "G:\test\retest\5.     \Rapport_.xlsx", WriteResPassword:="XXXX", IgnoreReadOnlyRecommended:=True
 
'Fige l'écran pendant la suppression des lignes
    Application.ScreenUpdating = False
 
'Désactiver les alertes pour empêcher l'affichage ' des messages du genre "Voulez-vous etc."
    Application.DisplayAlerts = False
 
'On définit les variables
Set FD = ActiveWorkbook
Set SD0 = FD.Worksheets("donnees ") 'Pour les colonnes E et F
Set SD1 = FD.Worksheets("Placement") 'Pour la colonne AH
Set SD2 = FD.Worksheets("dernier entretien")
Set SD3 = FD.Worksheets("DE_actifs")
 
'On efface l'onglet "TEST dernier entr." s'il existe
    If FExist("TEST dernier entr.") Then
        FD.Worksheets("TEST dernier entr.").Delete
    Else
 
    End If

C'EST SUR CETTE PARTIE QUE CELA BUG

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
'Pour chaque ID on copie les valeurs de la "Situation initiale - Saisi le"
'et "l'employabilité" de l'onglet "donnees"
    For i = 2 To LastRowSS
        NDE = SS0.Cells(i, 3).Value
        j = SD0.Range("C:C").Find(What:=NDE, LookAt:=xlWhole).Row
        g = SD1.Range("E:E").Find(What:=NDE, LookAt:=xlWhole).Row
 
        SD0.Activate
        Cells(j, 6).Copy
        SS0.Activate
        SS0.Cells(i, 9).Select
         ActiveCell.PasteSpecial Paste:=xlPasteValues
 
'Pour chaque DE on copie les valeurs de la "Situation professionnelle"
'de l'onglet "Placement"
        SD1.Cells(g, 34).Copy
        SS0.Cells(i, 8).Select
        ActiveCell.PasteSpecial Paste:=xlPasteValues
        Set j = Nothing
        Set g = Nothing
    Next i

A PARTIR DE LA CELA FONCTIONNE A NOUVEAU

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
'On met les titres de colonnes
    SD0.Cells(1, 6).Copy SS0.Cells(1, 9)
    SD1.Cells(1, 34).Copy SS0.Cells(1, 8)
 
'On met en forme les titres de colonnes
    SS0.Activate
    Range("A1:O1").Select
    With Selection
        .VerticalAlignment = xlBottom
        .WrapText = True
        .orientation = 90
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
'On adapte la largueur des colonnes
    Cells.EntireColumn.AutoFit
 
'On effacer le fond des cellules et on met une ligne sur 2 en grisé
    Range(Cells(1, 1), Cells(LastRowSS, 15)).Select
    Selection.Interior.ColorIndex = xlColorIndexNone
        Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=MOD(LIGNE();2)"
        Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
            With Selection.FormatConditions(1).Interior
                .PatternColorIndex = xlAutomatic
                .ThemeColor = xlThemeColorDark1
                .TintAndShade = -0.249946592608417
            End With
        Selection.FormatConditions(1).StopIfTrue = False
        Selection.AutoFilter
 
'On trie du plus grand au plus petit les écarts d'entretiens
    SS0.AutoFilter.Sort.SortFields.Clear
    SS0.AutoFilter.Sort.SortFields.Add _
        Key:=Range("D1:D" & LastRowSS), SortOn:=xlSortOnValues, Order:=xlDescending, _
        DataOption:=xlSortNormal
    With SS0.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
    Range(Cells(2, 4), Cells(LastRowSS, 4)).Select
'On met en évidence tout les cellules de la colonne "D" avec une valeur supérieure ou égale à 60
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlGreaterEqual _
        , Formula1:="=60"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .italic = False
        .Color = -16776961
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 11515107
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 
'On met en évidence tout les cellules de la colonne "D" avec une valeur comprise entre 45 et 59
    Selection.FormatConditions.Add Type:=xlCellValue, Operator:=xlBetween, _
        Formula1:="=45", Formula2:="=59"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Font
        .Bold = True
        .italic = False
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = 0
    End With
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent4
        .TintAndShade = 0.599963377788629
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 
'On renomme l'onglet
    SS0.Name = "TEST dernier entr."
    SD2.Visible = False
 
'On copie l'onglet sur le fichier "Rapport_"
    SS0.Copy After:=SD2
 
'CETTE PARTIE DU CODE EST UTILISEE POUR LE CONTROLE DES DONNES SYSTEME ET
'REPREND LA MACRO "CONTROLE _SAISIE_SYSTEME"
 
'On active l'onglet "actifs" du fichier "Rapport_"
    SD3.Activate
 
LastRowD3 = SD3.Range("A" & Rows.Count).End(xlUp).Row
 
'On met la colonne R en format Date
    Columns("R:R").TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 4), TrailingMinusNumbers:=True
 
'On insère une colonne T
    Columns("T:T").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
 
'On fait la soustraction entre la date d'inscription et la date d'entrée en service
    Range("T2") = "Contrôle de saisie PLASTA"
    Range("T3").FormulaR1C1 = "=RC[-2]-RC[-1]"
    Range("T3").AutoFill Destination:=Range("T3:T" & LastRowD3), Type:=xlFillDefaul
 
'On met la colonne T en format standard
    Columns("T:T").NumberFormat = "General"
 
'On filtre et on trie sur la colonne "Contrôle de saisie SYSTEME" afin de
'trouver les valeurs exceptionnelles signes d'une erreur de saisie.
    Rows("2:2").AutoFilter
    SD3.AutoFilter.Sort.SortFields.Clear
    SD3.AutoFilter.Sort.SortFields.Add _
        Key:=Range("T2"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With SD3.AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
'FIN DE LA PARTIE DU CODE UTILISEE POUR LE CONTROLE DES DONNES SYSTEME ET
'REPRENNANT LA MACRO "CONTROLE _SAISIE_SYSTEME"
 
'Défige l'écran pendant la suppression des lignes
    Application.ScreenUpdating = True
 
'Activer les alertes pour empêcher l'affichage ' des messages du genre "Voulez-vous etc."
    Application.DisplayAlerts = True
 
 
'On sauve le fichier "Rapport_" en gardant l'option lecture seule
    FD.SaveAs "G:\test\retest\5.     \Rapport_.xlsx", WriteResPassword:="XXXX", ReadOnlyRecommended:=True
    FD.Close
 
 
    FS.Close Savechanges:=False
 
End Sub

**Zekraoui_Jakani** · 30/03/2022, 12h34

Vous pouvez poster copie du fichier avec des données fictives !

**21Formatic** · 30/03/2022, 14h20

Bonjour,
Travailler en mémoire serait effectivement plus rapide. Cela dit, si on veut poursuivre dans la voie actuelle, tu peux essayer ceci :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'Pour chaque ID on copie les valeurs de la "Situation initiale - Saisi le"
'et "l'employabilité" de l'onglet "donnees"
For i = 2 To LastRowSS
NDE = SS0.Cells(i, 3).Value
j = SD0.Range("C:C").Find(What:=NDE, LookAt:=xlWhole).Row
g = SD1.Range("E:E").Find(What:=NDE, LookAt:=xlWhole).Row
 
SS0.Cells(i, 9).value = SD0.Cells(j, 6).value
 
'Pour chaque DE on copie les valeurs de la "Situation professionnelle" de l'onglet "Placement"
SS0.Cells(i, 8).value = SD1.Cells(g, 34).value
Next i
Set j = Nothing
Set g = Nothing

Aucun intérêt à priori à réinitialiser les variables au milieu de la boucle. Tous les .select ralentissent énormément le code. Cela devrait être plus rapide ainsi.

**Gladiator75** · 30/03/2022, 21h59

Bonsoir,

Je me suis aperçu que j'avais oublié de mettre les balises ce qui n'a pas dû faciliter la lecture ou donner envie de s'y pencher dessus...

@21Formatic: Merci pour la proposition, je vais la tester demain et je vous redis comment.

@Zekraoui_Jakani: effectivement, j'aurais pu modifier les fichiers pour les envoyer avec des données fictives mais je pensais - certainement à tort - que l'optimisation de la boucle ne le nécessitait pas forcément. Selon le gain de temps de 21Formatic, je ferai le nécessaire ou cliquerai sur "résolu".

Bonne soirée

**Philippe Tulliez** · 30/03/2022, 22h22

Bonjour,
J'ai parcouru très rapidement votre code
Quelques remarques

Vous utilisez des colonnes entières de la feuille ce qui est n'est pas une bonne pratique. Privilégiez des plages balisées (comme par exemple A2:A1000 plutôt que A:A mais évidemment je ne peux que vous conseiller l'usage des tableaux structurés ce qui vous permettra de ne pas vous préoccuper du nombre de lignes de votre colonne)
Vous utilisez les méthodes Select et Activate ce qui ne sert à rien en VBA et qui de plus est chronophage (cela ralenti évidemment l'exécution du programme)

**Gladiator75** · 31/03/2022, 10h50

Bonjour,

@21Formatic, j'ai testé ton code et effectivement cela change drastiquement les choses (env. 25 secondes de traitement au lieu des 7 minutes)

@Philippe : En effet, je sais que l'utilisation des tableaux permettrait de gagner en efficience mais, comme je suis peu à l'aise avec ce système, je vais encore rester à la méthode de la pierre. Un jour de pluie, il faudra que je m'y intéresse

.

Merci pour vos retours et je clos ma demande.

Optimisation d'une boucle [XL-2016]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager