Lenteur dans exécution

**Walt51** · 23/02/2017, 12h55

Bonjour,

J'ai un code ci-dessous.
Dès que j'entre une valeur dans la plage B20 à I141 il se passe environ 6" avnt que je puisse récupérer la main.

Qu'est qui prend autant de temps?
Quel solution y a-t-il?
Merci

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
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
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 
If Target.Address = "$C$4" Then
 
    H = Sheets("Repertoire SEDAM tempo").Range("Auteur").Value
    Me.ComboBoxChoixAuteur.List = H
    Me.ComboBoxChoixAuteur.Height = Target.Height + 3
    Me.ComboBoxChoixAuteur.Width = Target.Width
    Me.ComboBoxChoixAuteur.Top = Target.Top
    Me.ComboBoxChoixAuteur.Left = Target.Left
    Me.ComboBoxChoixAuteur = Target
    Me.ComboBoxChoixAuteur.Visible = True
    Me.ComboBoxChoixAuteur.Activate
  Else
    Me.ComboBoxChoixAuteur.Visible = False
 
 End If
 
If Target.Address <> "$B$20:$I$100" Then
    Call RemplissageInterlocuteur
    Call RemplissageNoCommande
    Call RemplissageFournisseur
 
End If
 
If Target.Address = "$E$4" Then
 
    f = Sheets("Repertoire fournisseurs tempo").Range("NomFournisseur").Value
    Me.ComboBoxChoixFournis.List = f
    Me.ComboBoxChoixFournis.Height = Target.Height + 3
    Me.ComboBoxChoixFournis.Width = Target.Width + 200
    Me.ComboBoxChoixFournis.Top = Target.Top
    Me.ComboBoxChoixFournis.Left = Target.Left
    Me.ComboBoxChoixFournis = Target
    Me.ComboBoxChoixFournis.Visible = True
    Me.ComboBoxChoixFournis.Activate
  Else
    Me.ComboBoxChoixFournis.Visible = False
 
 End If
 
 
 
If Target.Address = "$C$4" Or Target.Address = "$C$5" Then
    Call ChargerRepertoireSEDAM
End If
 
 
 
Dim repPdf As String
 
repPdf = "Y:\BASE DOCUMENT\BASE TECHNIQUE\Fichiers PDF des articles référencés\"
LigneSel = Windows(ThisWorkbook.Name).ActiveCell.Row
 
 
If Not Application.Intersect(Target, Range("J20:J141")) Is Nothing Then
    If Dir(repPdf & Sheets("Création de commande").Range("B" & LigneSel).Value & ".pdf") <> "" Then
    ThisWorkbook.FollowHyperlink repPdf & Range("B" & LigneSel) & ".pdf"
 End If
End If
 
 
 End Sub
 
 
 
 
 
 
Private Sub Worksheet_Change(ByVal Target As Range)
 
 
 
'+++++++++++++++++++++++++++++++++++++++++++++++ Récupération, désignation, matière, traitement, prix...+++++++++++++++++++++++++++++++++
 
Dim J As Long
    Dim cellule As Range
    Dim Tabl As Variant
 
    If Not Intersect(Target, [B20:B141]) Is Nothing Then
 
    Application.EnableEvents = False
 
    'Quand on entre une réf, on recupère désignation, matière, traitement, prix...
 
        Tabl = [ListeDesArticlesAImporter].Value2 '"Value2" recopie toutes les décimales
 
            For Each cellule In Target.Cells  'on lit chaque cellule modifiée
               For J = 1 To UBound(Tabl)
                   If Tabl(J, 2) = cellule.Value2 Then 'And Tabl(J, 7) = [E4]  Or Tabl(J, 2) = Cellule.Value2 And Tabl(J, 7) = "" Then 'Si le fournisseur correspond à l'article ou si fournisseur de l'article non renseigné alors
 
 
                       Application.EnableEvents = False
                       cellule.Offset(, 1) = Tabl(J, 3) 'colonne 1 (Désignation) par rapport à B = colonne 3 du tableau
                       cellule.Offset(, 2) = Tabl(J, 5) 'colonne 2 (Matière)
                       cellule.Offset(, 3) = Tabl(J, 6) 'colonne 3 (Traitement finition)
                       cellule.Offset(, 5) = Tabl(J, 8) 'colonne 3 (Unité)
 
 
                   End If
 
                    If Tabl(J, 2) = cellule.Value2 And Range("E4") <> "" And Tabl(J, 7) = [E4] Then  'Si fournisseur renseigné et article lié au fournisseur alors on renvoi le tarif du fournisseur
 
 
                       cellule.Offset(, 6) = Val(Replace((Tabl(J, 9)), ",", ".")) 'colonne 6 (PU € HT) VAL récupère la valeur numérique du prix qui est en format texte
                       Application.EnableEvents = True
                       Exit For
 
                     Else
                     'ne pas renvoyer de tarif si le fournisseur n'est pas renseigné dans l'entête
                   End If
 
               Next J
            Next
 
 
    End If
 
 
 
 
 
 
 '+++++++++++++++++++++++++++++++++++++++++++++++ Mise en forme +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
 
 
 
  Dim i As Integer
 
 
If Not Application.Intersect(Target, Range("B20:I141")) Is Nothing Then 'si pas de changement de valeur dans les cellules B20 à I141 => rien , sinon
 
Application.EnableEvents = False 'désactiver les évènements pendant la macro (sinon la macro ne peut pas supprimer les cellules
 
For i = 0 To 141 'compteur de 0 à 141 (pour toutes les lignes de 0 à 141)
 
If Range("B20").Offset(i).Value <> "" Or Range("C20").Offset(i).Value <> "" Then 'si à partir de B20 x compteur valeur non vide alors
    'CommandButtonGo.Visible = True 'Bouton GO visible
    Range("A20").Offset(i).Value = 1 + (i) 'Ajout n° de ligne +1
    Range("A20:E20").Offset(i).Borders.Value = 1 ' Ajout des bordures des lignes non vides
    End If
 
 
 
 
If Range("B20").Offset(i).Value <> "" Then
Dim repPdf As String
Dim cpt_pdf As Integer
 
repPdf = "Y:\BASE DOCUMENT\BASE TECHNIQUE\Fichiers PDF des articles référencés\"
 
 
 
    If Dir(repPdf & Sheets("Création de commande").Range("B20").Offset(i).Value & ".pdf") <> "" Then
 
      Range("J20").Offset(i).Value = "Lien PDF"
 
    Else
 
     Range("J20").Offset(i).Value = ""
 
    End If
End If
 
 
If Range("B20").Offset(i).Value = "" And Range("C20").Offset(i).Value = "" Then ' Si colonne B et C vide, alors
    Range("A20").Offset(i).Value = ""   'Suppression du n° de ligne
    Range("A20:E20").Offset(i).Borders.Value = 0    'Suppression des bordures
    Range("J20").Offset(i).Value = ""
    End If
 
 
If Range("F20").Offset(i).Value <> "" Then 'Si QTE non vide alors
    Range("F20").Offset(i).Borders.Value = 1 'mettre les bordures
    End If
 
If Range("F20").Offset(i).Value = "" Then 'Si QTE vide alors
    Range("F20").Offset(i).Borders.Value = 0 'Supprimer les bordures
    End If
 
If Not IsNumeric(Range("F20").Offset(i).Value) Then 'Si QTE autre que nombre alors
    MsgBox "Entrez obligatoirment un nombre", vbExclamation, "Quantité"
    Range("F20").Offset(i).Value = 0 'Supprimer
    End If
 
If Range("G20").Offset(i).Value <> "" Then 'Colonne unité
    Range("G20").Offset(i).Borders.Value = 1
    End If
 
If Range("G20").Offset(i).Value = "" Then 'Colonne unité
    Range("G20").Offset(i).Borders.Value = 0
    End If
 
If Range("G20").Offset(i).Value <> "" Then
        If Range("G20").Offset(i).Value <> "U" And _
            Range("G20").Offset(i).Value <> "C" And _
            Range("G20").Offset(i).Value <> "M" And _
            Range("G20").Offset(i).Value <> "M²" And _
            Range("G20").Offset(i).Value <> "L" And _
            Range("G20").Offset(i).Value <> "Kg" Then  'Colonne unité
        MsgBox "Entrez obligatoirment une unité valide", vbExclamation, "Unité"
        Range("G20").Offset(i).Value = ""
        End If
    End If
 
If Range("H20").Offset(i).Value <> "" Then 'Si PU non vide alors
    Range("H20").Offset(i).NumberFormat = "# ##0.00 €" 'Mise en forme PU #.##
    Range("H20").Offset(i).Value = CDbl(Range("H20").Offset(i).Value)
    Range("H20:I20").Offset(i).Borders.Value = 1
    Range("I20").Offset(i).Value = Range("F20").Offset(i).Value * Range("H20").Offset(i).Value 'PT = Qté x PU
    Range("I20").Offset(i).NumberFormat = "#,##0.00 €" 'Mise en forme PT
    End If
 
If Range("H20").Offset(i).Value = "" Then 'Si PU =0 alors
    Range("H20:I20").Offset(i).Borders.Value = 0 'Supprimer les bordures PU et PT
    Range("H20").Offset(i).Value = "" 'Supprimer le PU (pas de 0)
    Range("I20").Offset(i).Value = "" 'Supprimer le PT
    End If
 
Next
 
Application.EnableEvents = True 'Résactiver les évènements pendant la macro
 
 
'Double ligne séparation page1/2
 
    Range("A42:I42").Borders(xlEdgeBottom).LineStyle = xlDouble
 
'Double ligne séparation page2/3
 
    Range("A75:I75").Borders(xlEdgeBottom).LineStyle = xlDouble
 
'Double ligne séparation page3/4
 
    Range("A108:I108").Borders(xlEdgeBottom).LineStyle = xlDouble
 
 
 
   'Total quantité
 
        Range("L19").Value = "Total des pièces: "
        Range("M19").Value = Application.WorksheetFunction.Sum(Range("F20:F141" & DernLigne))
 
 
 
    'Total prix
 
        Range("L17").Value = "Montant total: "
        Range("N17").Value = Application.WorksheetFunction.Sum(Range("I20:I141" & DerLig))
 
        If Range("N17").Value > 5000 Then
        MsgBox "Montant supérieur à 5000€ , demandez au patron!", vbOKOnly + vbExclamation, "attention à la dépense"
        End If
 
 
End If
 
End Sub

**Marc-L** · 23/02/2017, 13h08

Bonjour,

c'est normal, il y a 150 lignes de code (!) pour de la mise en forme forcément lente sous Excel.

Comme d'habitude, penser à désactiver l'affichage durant la procédure … (ScreenUpdating)

Sinon en utilisant le B-A-BA d'Excel à savoir une table, nullement besoin de mise en forme supplémentaire
car elle est déjà automatique lors de l'ajout d'une ligne dans la table !

_________________________________________________________________________________________________________

Je suis Paris, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

Lenteur dans exécution

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager