Optimisation de fichier/Macro VBA

**PaPyyHo** · 15/11/2017, 15h12

Bonjour à tous,
Je viens de finaliser un tableau qui me permet de comparer et de suivre les évolutions de nomenclature de nos produits.
Le fonctionnement de ce tableau:
- j’extrais une BOM dans la page NomencMN
- je lance ma macro de mise en forme via le bouton du même nom
- cette macro récupère les infos contenu dans NomencMN et les inserts dans une nouvelle feuille en comparant chaque ligne avec les ligne de précédente extraction (si une 1ere extraction à été faite)
- une fois la page créer j'ai possibilité de faire des tries en fonction des valeur renseigner dans les cases grises de la nouvelle feuille. (trie par niveau, par code article, par N° de repère, par quantité et enfin d'isoler la nomenclature d'un article et de ces enfants)

Le fichier marche très bien et je suis plutôt content de ma macro mais nos produits pouvant contenir plusieurs millier de ligne cela peu devenir très/trop long.
Étant novice en VBA j'ai pu faire des choix dans la conception de mon fichier qui ne serait pas optimisé.

Auriez-vous des remarques qui me permettrais de diminuer le temps de génération de chaque nouvelle page?
Merci d'avance à ceux qui prendrons le temps de me répondre.

**PaPyyHo** · 15/11/2017, 15h35

Je viens de prendre conscience qu'il ne fallais pas mettre de fichier au 1er poste.

Je vous poste donc en complément mon code que j'ai placer dans le module 1:

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
260
261
262
263
264
265
266
267
268
269
Public Lmax As Integer
Public NewSheetName As String
Public SheetNumber As Integer
 
Sub MiseEnForme()
 
Dim i As Integer
Dim J As Integer
Dim Jmax As Integer
Dim Ligne As Integer
Dim LvL As Integer
Dim ClefNiveau(1 To 10) As String
 
Dim TexteCopi As String
Dim KO As String
 
KO = "KO"
 
i = 10
Lmax = 1
Jmax = Application.WorksheetFunction.Max(Sheets("NomencMN").Range("J:J"))
 
'Trie croissant par numero de sequence
    ActiveWorkbook.Worksheets("NomencMN").ListObjects("ResultSet_NomencMN").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("NomencMN").ListObjects("ResultSet_NomencMN").Sort. _
        SortFields.Add Key:=Range("ResultSet_NomencMN[[#All],[Sequence]]"), SortOn _
        :=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("NomencMN").ListObjects("ResultSet_NomencMN"). _
        Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
 
'Création nouvelle feuille
    Call AddSheet
    NewSheetName = ActiveSheet.Name
    SheetNumber = Worksheets.Count
 
    Do While (Sheets("NomencMN").Cells(i, 1) <> "")
        Ligne = i - 7
 
'Ajout de la fomule de validation via parent validé "=SI(A3<>"";SI(ET(B2<D3;B2<>"");B2;D3);SI(ET(B2<D3;B2<>"");B2;""))"
        Sheets(NewSheetName).Cells(Ligne, 3).FormulaR1C1 = _
              "=if(RC[-1]<>"""",if(AND(R[-1]C<RC[1],R[-1]C<>""""),R[-1]C,RC[1])," _
            & " if(AND(R[-1]C<RC[1],R[-1]C<>""""),R[-1]C,""""))"
'Ajout de la fomule de detection des eccars avec vielle feuille
        If SheetNumber > 4 Then
            Sheets(NewSheetName).Cells(Ligne, 18).FormulaR1C1 = _
                "=IF(ISNA(VLOOKUP(RC[-17],'" & Sheets(5).Name & "'!C[-17],1,0)),""KO"","""")"
        End If
'Copie du niveau
        LvL = Sheets("NomencMN").Cells(i, 10)
        Sheets(NewSheetName).Cells(Ligne, 4) = LvL
            For J = 1 To Jmax
                If Sheets(NewSheetName).Cells(Ligne, 4) >= Sheets(NewSheetName).Cells(2, 3 + J) Then
                    Sheets(NewSheetName).Cells(Ligne, 3 + J) = Sheets(NewSheetName).Cells(Ligne, 4)
                Else
                    J = Jmax
                End If
            Next J
'Copie du code article
        TexteCopi = Sheets("NomencMN").Cells(i, 11)
        TexteCopi = RTrim(TexteCopi)
        Sheets(NewSheetName).Cells(Ligne, 14) = "'" & TexteCopi
'Copie de la description
        Sheets(NewSheetName).Cells(Ligne, 15) = Sheets("NomencMN").Cells(i, 12)
'Copie du numero de repere
        TexteCopi = Sheets("NomencMN").Cells(i, 7)
        TexteCopi = RTrim(TexteCopi)
        Sheets(NewSheetName).Cells(Ligne, 16) = "'" & TexteCopi
'Copie de la quantité
        TexteCopi = Sheets("NomencMN").Cells(i, 13)
        TexteCopi = RTrim(TexteCopi)
        Sheets(NewSheetName).Cells(Ligne, 17) = "'" & TexteCopi
'Création de la clef de ligne
        If LvL > 1 Then
            ClefNiveau(LvL) = ClefNiveau(LvL - 1) & Sheets(NewSheetName).Cells(Ligne, 14) _
                & Sheets(NewSheetName).Cells(Ligne, 16) & Sheets(NewSheetName).Cells(Ligne, 17)
        Else
            ClefNiveau(LvL) = Sheets(NewSheetName).Cells(Ligne, 14) _
                & Sheets(NewSheetName).Cells(Ligne, 16) & Sheets(NewSheetName).Cells(Ligne, 17)
        End If
        Sheets(NewSheetName).Cells(Ligne, 1) = ClefNiveau(LvL)
'Copie de l'etat
        Sheets(NewSheetName).Cells(Ligne, 2) = Application.VLookup(Sheets(NewSheetName).Cells(Ligne, 1) _
            , Sheets(5).Range("A:R"), 2, False)
'Fin de la boucle
        i = i + 1
    Loop
    Lmax = Ligne
 
'Mise en forme de la feuille complete
    Call FormatSheet
 
'Acces à la macro de trie
    ActiveSheet.Range("C1").ClearContents
 
'Protection de la feuille RemiseEnForme retravailler
   ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
      , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
      AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
    Range("A1").Select
 
End Sub
 
 
Sub FormatSheet()
'
'Quadrillage
    Sheets(NewSheetName).Select
    Sheets(NewSheetName).Range(Cells(3, 1), Cells(Lmax, 18)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
 
'Mise en forme conditionelle rouge si eccard
    Cells.FormatConditions.Delete
    Sheets(NewSheetName).Range(Cells(3, 1), Cells(Lmax, 18)).Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=SI($R3=""KO"";1;0)"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 
'Mise en forme conditionelle vert si non vide
    Sheets(NewSheetName).Range(Cells(3, 1), Cells(Lmax, 18)).Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=SI($C3<>"""";1;0)"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
 
 
 
End Sub
 
Sub AddSheet()
'
'
'Création nouvelle feuille + renommage de la feuille
Dim LastSheetName As String
 
    Sheets("Empty").Visible = True
    Sheets("Empty").Copy After:=Sheets(3)
    SheetNumber = Worksheets.Count
    Sheets("Empty").Visible = False
 
    Sheets(4).Select
    NewSheetName = Format(Date, "dd-mm-yyyy") & "_" & SheetNumber
    ActiveSheet.Name = NewSheetName
 
'Mise en couleur des onglets
    With ActiveWorkbook.Sheets(4).Tab
        .Color = 5296274
        .TintAndShade = 0
    End With
 
    If SheetNumber > 4 Then
        With ActiveWorkbook.Sheets(5).Tab
            .Color = 49407
            .TintAndShade = 0
        End With
        If SheetNumber > 5 Then
            With ActiveWorkbook.Sheets(6).Tab
                .Color = 255
                .TintAndShade = 0
            End With
        End If
    End If
 
End Sub
 
Sub ClefNiveauUPdate()
'
Dim i As Integer
Dim LvL As Integer
Dim ParentLvL As String
Dim ClefNiveau(1 To 10) As String
Dim OldClef As String
 
i = 3
ParentLvL = "xxxxxxxxxxx"
 
ActiveSheet.Unprotect
ActiveSheet.Range("C1") = "X"
 
'Régénération de la clef de niveau
    Do While (ActiveSheet.Cells(i, 1) <> "")
        OldClef = ActiveSheet.Cells(i, 1)
        LvL = ActiveSheet.Cells(i, 4)
        If LvL > 1 Then
            ClefNiveau(LvL) = ClefNiveau(LvL - 1) & ActiveSheet.Cells(i, 14) _
                & ActiveSheet.Cells(i, 16) & ActiveSheet.Cells(i, 17)
        Else
            ClefNiveau(LvL) = ActiveSheet.Cells(i, 14) _
                & ActiveSheet.Cells(i, 16) & ActiveSheet.Cells(i, 17)
        End If
        If OldClef <> ClefNiveau(LvL) Then
            If Left$(ClefNiveau(LvL), Len(ParentLvL)) <> ParentLvL Then
                ActiveSheet.Cells(i, 14).Select
                Select Case MsgBox("Voulez-vous mettre à jour la clef de l'article selectioné?", vbYesNo)
                    Case vbYes
                        ActiveSheet.Cells(i, 1) = ClefNiveau(LvL)
                        ParentLvL = ClefNiveau(LvL)
                    Case vbNo
                        Exit Sub
                End Select
            Else
                ActiveSheet.Cells(i, 1) = ClefNiveau(LvL)
            End If
        End If
        i = i + 1
    Loop
'Acces à la macro de trie
    ActiveSheet.Range("C1").ClearContents
'Protection de la feuille RemiseEnForme retravailler
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
      , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
      AllowFormattingRows:=True, AllowSorting:=True, AllowFiltering:=True
    Range("A1").Select
 
End Sub

Et et parallele le code placé dans la nouvelle feuille créée:

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
Private Sub Worksheet_Change(ByVal Target As Range)
 
    ActiveSheet.Unprotect
    If ActiveSheet.Range("C1") <> "" Then
        Exit Sub
    Else
'Trie sur niveau
        If Target.Address = Range("D1").Address Then
            If Range("D1") = "" Then
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=4
            Else
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=4, Criteria1:="<=" & ActiveSheet.Range("$D$1"), _
                    Operator:=xlAnd
            End If
        End If
'Trie sur code article
        If Target.Address = Range("N1").Address Then
            If Range("N1") = "" Then
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=14
            Else
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=14, Criteria1:="*" & ActiveSheet.Range("$N$1") & "*", _
                    Operator:=xlAnd
            End If
        End If
'Trie sur repere
        If Target.Address = Range("P1").Address Then
            If Range("P1") = "" Then
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=16
            Else
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=16, Criteria1:="*" & ActiveSheet.Range("$P$1") & "*", _
                    Operator:=xlAnd
            End If
        End If
'Trie sur Qté
        If Target.Address = Range("Q1").Address Then
            If Range("Q1") = "" Then
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=17
            Else
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=17, Criteria1:="*" & ActiveSheet.Range("$Q$1") & "*", _
                    Operator:=xlAnd
            End If
        End If
'Afficher seulement les composant de l'article:
        If Target.Address = Range("S1").Address Then
            If Range("S1") = "" Then
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=1
            Else
                ActiveSheet.Range("$A$2:$S$2").AutoFilter Field:=1, Criteria1:=ActiveSheet.Range("$S$1") & "*", _
                    Operator:=xlAnd
            End If
        End If
    End If
End Sub

**Marc-L** · 15/11/2017, 16h12

Bonjour,

désactiver déjà l'affichage via la propriété ScreenUpdating (consulter l'aide VBA interne au besoin).

Pas le temps de décrypter les plus de 300 lignes de code pour visualiser le besoin exact, méritant bien une présentation technique …
En concevant un classeur modèle déjà mis en forme via une table, il y aurait juste à y copier les données.

Excel n'étant pas un gestionnaire de bases de données, ce genre de traitement devrait être bien plus rapide sous Access …

___________________________________________________________________________________________________________

Je suis Paris, New-York, Mogadicio, Barcelone, London, Manchester, Egypte, Stockholm, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

**PaPyyHo** · 15/11/2017, 19h06

Merci du conseil,
j'ai ajouter quelques désactivation au moment de mes boucles de récupération et ça va BEAUCOUP plus vite (j'ai fait de calcul mais à vu d’œil sur mon export de test j'ai divisé le temps par 5.
Pour ceux que ça intéresserait voici ce qu'il faut ajouter:

Code :

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

1
2
3
4
5
6
7
            'Désactivation de l'actualisation de l'affichage
                Application.ScreenUpdating = False
 
                CODE
 
            'Activation de l'actualisation de l'affichage
                Application.ScreenUpdating = True

Optimisation de fichier/Macro VBA

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager