Optimisation de code

**breizhgen** · 11/12/2023, 20h03

Bonjour,

j'ai réalisé un bout de code VBA qui réalise plusieurs boucles dans l'intérieur de boucles... Le résultat fonctionne sans problème mais cela est très long pour traiter des milliers de lignes. Je suis persuadé que mon code est très loin d'être parfait et optimisé et j'ai besoin de vos lumières pour voir si je ne pourrais pas le modifier pour gagner en vitesse de traitement.

Voici le 1er code :

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
Sub bloc_tag1() 'Import des groupes de tag
 
Application.ScreenUpdating = False
 
Dim FL1 As Worksheet, Cell As Range, NoCol As Integer
Dim NoLig As Long, derlig As Long, Var As Variant
 
    'Instance de la feuille qui permet d'utiliser FL1 partout dans
    'le code à la place du nom de la feuille
    Set FL1 = Worksheets("Vidus")
 
    'Détermine la dernière ligne renseignée de la feuille de calculs
 
    derlig = Split(FL1.UsedRange.Address, "$")(4)
 
    'Fixe le N° de la colonne à lire
    NoCol = 1
 
 
    For NoLig = 1 To derlig
        Var = FL1.Cells(NoLig, NoCol)
 
    Sheets("Vidus").Select
 
 
 
lignedeb = Range("B" & NoLig).Value
lignefin = Range("C" & NoLig).Value
 
 
    Sheets("FICHIER").Select ' Récupèration bloc VIDUS
     Range("A" & lignedeb & ":A" & lignefin).Select
    Selection.Copy
    Sheets("GroupeTAG").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("1:1").Select
 
 
    envoibdd
 
    Sheets("GroupeTAG").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    Range("A1").Select
 
      Next
    Set FL1 = Nothing
 
        Sheets("FICHIER").Select
    Range("A1").Select
 
    Application.ScreenUpdating = True
 
 
End Sub

qui appelle le sub envoibdd ci-dessous :

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
Sub envoibdd() 'Cherche 1 mot et marque la ligne
Dim rg As Range
Dim FL1 As Worksheet, Cell As Range, NoCol As Integer
Dim NoLig As Long, derlig As Long, Var As Variant
Dim Texte As String
Dim derligne As Long
 
     Sheets("GroupeTAG").Select
 
    Application.ScreenUpdating = False
 ' Application.Calculation = xlManual
  Application.DisplayStatusBar = False
 
    'Instance de la feuille qui permet d'utiliser FL1 partout dans
    'le code à la place du nom de la feuille
    Set FL1 = Worksheets("GroupeTAG")
 
        'Détermine la dernière ligne renseignée de la feuille de calculs
 
    derlig = Split(FL1.UsedRange.Address, "$")(4)
 
      'Fixe le N° de la colonne à lire
    NoCol = 1
 
 
    For NoLig = 1 To derlig
 
 
 
        If Range("A" & NoLig).Value Like "0 A*" Then
 
        Var1 = Range("A" & NoLig).Value
 
    End If
 
    If Range("A" & NoLig).Value Like "2 RN *" Then
 
        Var2 = Range("A" & NoLig).Value
 
     End If
 
     If Range("A" & NoLig).Value Like "2 VN *" Then
 
        Var3 = Range("A" & NoLig).Value
 
        End If
 
    If Range("A" & NoLig).Value Like "1 SX *" Then
 
        Var4 = Range("A" & NoLig).Value
 
        End If
 
    If Range("A" & NoLig).Value Like "1 ACCU *" Then
 
        Var5 = Range("A" & NoLig).Value
 
        End If
 
 
 
    If Range("A" & NoLig).Value Like "1 GN *" Then
 
        Var8 = Range("A" & NoLig).Value
 
        End If
 
            If Range("A" & NoLig).Value Like "1 AMS*" Then
 
        Var6 = Range("A" & NoLig).Value
 
 
        End If
 
             If Range("A" & NoLig).Value Like "1 _FI*" Then
 
 
 
        Var7 = Range("A" & NoLig).Value
 
       End If
 
 If Range("A" & NoLig).Value Like "1 AMC*" Then
 
        Var9 = Range("A" & NoLig).Value
 
        End If
 
        finmot = Range("A" & derlig).Value
 
  If Range("A" & NoLig).Value Like finmot Then
 
        Sheets("BDD").Select
 
        derligne = Range("A" & Rows.Count).End(xlUp).Row
        derligne = derligne + 1
 
        Range("A" & derligne).Value = Var1
        Range("B" & derligne).Value = Var2
        Range("C" & derligne).Value = Var3
        Range("D" & derligne).Value = Var4
        Range("E" & derligne).Value = Var5
 
        Range("H" & derligne).Value = Var6
        Range("K" & derligne).Value = Var7
        Range("J" & derligne).Value = Var8
        Range("I" & derligne).Value = Var9
 
        Sheets("GroupeTAG").Select
 
    End If
 
    Next
    Set FL1 = Nothing
 
     Application.ScreenUpdating = True
  'Application.Calculation = xlManual
  Application.DisplayStatusBar = True
 
End Sub

En vous remerciant pour vos conseils

**a_diard** · 11/12/2023, 21h00

Il faut commencer pas supprimer les .select

**Philippe Tulliez** · 12/12/2023, 00h32

Bonjour,
J'ai répondu pour un cas similaire dans cette discussion titrée .Copy .pastespecial entre deux classeurs

**deedolith** · 12/12/2023, 10h55

Salut,

Je t'invite à passer par des tableaux structurés, c'est plus simple à manipuler qu'une plage de cellules arbitraire.
Je t'invite également à passer par Power Query autant que possible.

**Tête de chat** · 12/12/2023, 14h37

Bonjour,

Déjà penses à indenter ton code correctement, à déclarer les variables, et vire les select comme l'a écrit a_diard (tant qu'à définir FL1, utilise-le)

Tu gagneras un peu en perf, beaucoup en lisibilité et en fiabilité

Ça ressemblerait pour le premier Sub à :

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
Sub bloc_tag1() 'Import des groupes de tag
 
    Dim NoLig As Long, DerLig As Long, NoCol As Integer
    Dim LigneDeb As Long, LigneFin As Long
 
    Application.ScreenUpdating = False
 
    With ThisWorkbook.Worksheets("Vidus")
 
        DerLig = Split(.UsedRange.Address, "$")(4)
 
        'Fixe le N° de la colonne à lire
        NoCol = 1
 
        For NoLig = 1 To DerLig
 
            LigneDeb = .Range("B" & NoLig).Value
            LigneFin = .Range("C" & NoLig).Value
 
            EnvoiBDD ThisWorkbook.Worksheets("FICHIER").Range("A" & LigneDeb & ":A" & LigneFin)
 
        Next
 
    End With
 
    Application.ScreenUpdating = True
 
 
End Sub

Au passage j'ai viré Var et Cell (dangereux comme nom, en plus) qui ne servaient à rien.

Ce que j'ai fait aussi c'est virer le copier/coller vers la feuille de manœuvre et j'ai passé la plage en paramètre à envoibdd.

Je finis de nettoyer EnvoBDD et je poste en dessous.

[Edit] suppression d'un commentaire erroné sur modifBDD.

**Tête de chat** · 12/12/2023, 15h02

Re

ci-dessous.

Tu vas gagner les select, le copier/coller, plus le nettoyage des données, passées en paramètre à EnvoiBDD. Ça devrait déjà se voir.
Après il faudrait regarder dans le détail ce qu'on est en train de faire pour voir s'il est possible de le faire autrement (formule, PowerQuery...)

Tu peux aussi remettre le application.calculation = xlCalculationManual mais dans le sub principal (sans oublier le = xlCalculationAutomatic à la fin)

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
Option Explicit
Sub bloc_tag1() 'Import des groupes de tag
 
    Dim NoLig As Long, DerLig As Long
    Dim LigneDeb As Long, LigneFin As Long
 
    Application.ScreenUpdating = False
 
    With ThisWorkbook.Worksheets("Vidus")
 
        DerLig = Split(.UsedRange.Address, "$")(4)
 
        For NoLig = 1 To DerLig
 
            LigneDeb = .Range("B" & NoLig).Value
            LigneFin = .Range("C" & NoLig).Value
 
            EnvoiBDD ThisWorkbook.Worksheets("FICHIER").Range("A" & LigneDeb & ":A" & LigneFin)
 
        Next
 
    End With
 
    Application.ScreenUpdating = True
 
 
End Sub
 
Sub EnvoiBDD(MaRange As Range) 'Cherche 1 mot et marque la ligne
 
    Dim MaCellule As Range
    Dim Var(9) As String
    Dim DerLigne As Long, I As Integer
 
    For Each MaCellule In MaRange.Cells
        With MaCellule
            If .Value Like "0 A*" Then
                Var(1) = .Value
            ElseIf .Value Like "2 RN *" Then
                Var(2) = .Value
            ElseIf .Value Like "2 VN *" Then
                Var(3) = .Value
            ElseIf .Value Like "1 SX *" Then
                Var(4) = .Value
            ElseIf .Value Like "1 ACCU *" Then
                Var(5) = .Value
            ElseIf .Value Like "1 AMS*" Then
                Var(6) = .Value
            ElseIf .Value Like "1 _FI*" Then
                Var(7) = .Value
            ElseIf .Value Like "1 GN *" Then
                Var(8) = .Value
            ElseIf .Value Like "1 AMC*" Then
                Var(9) = .Value
            End If
        End With
    Next MaCellule
 
    With ThisWorkbook.Worksheets("BDD")
        DerLigne = .Range("A" & .Rows.Count).End(xlUp).Row + 1
        For I = 1 To 9
            .Cells(DerLigne, I) = Var(I)
        Next I
    End With
 
End Sub

Optimisation de code

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager