Macro VBA très lente, comment l'optimiser

Version imprimable

Bonjour,

Je viens juste de débuter la programmation VBA pour me faire des macros sous excel pour automatiser mon travail.

J'ai réalisé une macro qui doit parcourir une extraction excel de 2500 ligne. Le programme doit parcourir chaque ligne pour récuperer le contenu de 6 cellules (de la ligne en cours) et comparer 2 cellules toujours de la ligne en cours, le tout est envoyé sur une autre pour mise en forme.

Mon programme marche et j'ai le résultat souhaité sauf ....... il est très long à l'exécution......

Pouvez vous me dire ce que je pourrais améliorer (ou mal fais) pour rendre le programme bien plus rapide ?

merci de votre aide

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
 
 
Dim nom As String
    Dim nom2 As String
 
    nom = Sheets(1).Name
    nom2 = Sheets(2).Name
 
    Sheets(nom).Activate
    Range("A18000").End(xlUp).Select
 
    Dim j As Integer
 
    j = ActiveCell.Row
 
    If j >= 6 Then
 
        Range("A6", "H" & j).Select
 
        Range("A6", "H" & j).Interior.Color = RGB(250, 250, 250)
 
        Selection.ClearContents
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        Selection.Interior.ColorIndex = xlNone
    End If
 
' lancement du trie
 
    Dim rayon As Integer
    Dim nbr_tb As Integer
    Dim nbr As Integer
    Dim stock_t As Currency
    Dim nbr_lig As Integer
 
    Sheets(nom2).Activate
 
    Range("A30000").End(xlUp).Select
 
    nbr_lig = ActiveCell.Row + 1
 
    nbr = 2
    Cells(nbr, 1).Select
 
    rayon = Mid(Cells(nbr, 1), 1, 1)
    nbr_tb = 6
 
    Sheets(nom).Range("C1").Value = "R" & rayon & "0"
 
    Do While Cells(nbr, 1) <> ""
 
        If Cells(nbr, 31) > 0 Then
 
            Sheets(nom).Range("A" & nbr_tb).Value = Cells(nbr, 1)
 
            Range("B" & nbr).Copy _
            Sheets(nom).Range("B" & nbr_tb)
 
            Range("I" & nbr).Copy _
            Sheets(nom).Range("C" & nbr_tb)
 
            Range("AE" & nbr).Copy _
            Sheets(nom).Range("D" & nbr_tb)
 
            Range("AK" & nbr).Copy _
            Sheets(nom).Range("E" & nbr_tb)
 
            Sheets(nom).Range("F" & nbr_tb).Value = Sheets(nom).Range("D" & nbr_tb) * Sheets(nom).Range("E" & nbr_tb)
 
            Range("M" & nbr).Copy _
            Sheets(nom).Range("G" & nbr_tb)
 
            Sheets(nom).Range("H" & nbr_tb).Value = (Range("M" & nbr) + Range("N" & nbr) + Range("O" & nbr) + Range("P" & nbr) + Range("Q" & nbr) + Range("R" & nbr) + Range("S" & nbr) + Range("T" & nbr) + Range("U" & nbr) + Range("V" & nbr) + Range("W" & nbr) + Range("X" & nbr)) / 12
 
 
            If Sheets(nom).Cells(nbr_tb, 4) > (2 * Sheets(nom).Cells(nbr_tb, 8)) Then
 
                Sheets(nom).Cells(nbr_tb, 4).Interior.Color = RGB(250, 0, 0)
 
            End If
 
            nbr_tb = nbr_tb + 1
 
        End If
 
        nbr = nbr + 1
    Loop
 
    Sheets(nom).Activate
 
    Range("A6:I" & nbr_tb).Sort Key1:=Range("F6"), Order1:=xlDescending, Header:= _
            xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
 
        Range("A30000").End(xlUp).Select
 
        j = ActiveCell.Row
 
        Range("A6", "H" & j).Select
 
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = True
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
 
        Range(("B6"), Range("B6").End(xlDown)).Select
 
        With Selection
            .HorizontalAlignment = xlLeft
            .VerticalAlignment = xlCenter
        End With
 
        Range(("F6"), Range("F6").End(xlDown)).Select
        Selection.Font.Bold = True
 
        Range("A5").Select

15/06/2015, 13h29
Marc-L

Bonjour,

désactiver l'affichage pendant la procédure, voir l'aide VBA de la propriété ScreenUpdating …

Tout ce qui est mise en page est long, à éviter par code. Sinon l'effectuer en globalité, pas ligne par ligne …
Pour un code efficace et donc rapide, il faut éviter les Activate et les Select ! Exemple ici …

En utilisant un filtre ou un filtre élaboré, copier un tableau nécessite guère plus de dix lignes de code !

_____________________________________________________________________________________________________

Merci de cliquer sur :plusser: pour chaque message ayant aidé puis sur :resolu: pour clore cette discussion …

_____________________________________________________________________________________________________
Je suis Charlie - Je suis Bardo

Merci

Dans le première version de mon programme j'ai mis du select de partout. Je me suis fais la réfléxion que cela devait en être la cause. J'ai donc presque tout viré mais sans résultat....

En fait la partie qui represente 95 % du temps de calcul est cette partie :

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
 
 
Do While Cells(nbr, 1) <> ""
 
        If Cells(nbr, 31) > 0 Then
 
            Sheets(nom).Range("A" & nbr_tb).Value = Cells(nbr, 1)
 
            Range("B" & nbr).Copy _
            Sheets(nom).Range("B" & nbr_tb)
 
            Range("I" & nbr).Copy _
            Sheets(nom).Range("C" & nbr_tb)
 
            Range("AE" & nbr).Copy _
            Sheets(nom).Range("D" & nbr_tb)
 
            Range("AK" & nbr).Copy _
            Sheets(nom).Range("E" & nbr_tb)
 
            Sheets(nom).Range("F" & nbr_tb).Value = Sheets(nom).Range("D" & nbr_tb) * Sheets(nom).Range("E" & nbr_tb)
 
            Range("M" & nbr).Copy _
            Sheets(nom).Range("G" & nbr_tb)
 
            Sheets(nom).Range("H" & nbr_tb).Value = (Range("M" & nbr) + Range("N" & nbr) + Range("O" & nbr) + Range("P" & nbr) + Range("Q" & nbr) + Range("R" & nbr) + Range("S" & nbr) + Range("T" & nbr) + Range("U" & nbr) + Range("V" & nbr) + Range("W" & nbr) + Range("X" & nbr)) / 12
 
 
            If Sheets(nom).Cells(nbr_tb, 4) > (2 * Sheets(nom).Cells(nbr_tb, 8)) Then
 
                Sheets(nom).Cells(nbr_tb, 4).Interior.Color = RGB(250, 0, 0)
 
            End If
 
            nbr_tb = nbr_tb + 1
 
        End If
 
        nbr = nbr + 1
    Loop

comme tu peux voir pas de select

merci pour tes liens qui m'aide pour d'autre projets

Bonjour,

on ne sait pas exactement ce que tu fais, car on ne connait pas les données et le résultat réel attendu

un fichier exemple présentant le fichier avant et après utilisation de ta macro aiderait grandement à améliorer ton code
en l'état, à part optimiser la rédaction, c'est difficile de changer de manière pertinente les procédés que tu utilises
et je devine sans mal qu'il y a matière à hautement optimiser ta méthode ... par exemple en utilisant un tableau Virtuel VBA pour traiter les données (encore que ... faut voir le fichier !!), ou l'utilisation des filtres avancés comme indiqué par Marc-L

en attendant, voici un début simplification possible de ton code
ATTENTION : impossible de le tester, je ne peux garantir qu'il soit conforme sans voir le fichier !!

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
 
Sub test()
 
Dim ShSource As Worksheet
Dim ShDest As Worksheet
Dim Rayon As Long
Dim Nbr_Tb As Long
Dim DerLig As Long
Dim i As Long
Dim j As Long
 
Application.ScreenUpdating = False
Set ShSource = Sheets(1)
Set ShDest = Sheets(2)
 
With ShSource
    DerLig = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    If DerLig >= 6 Then
        With .Range("A6", "H" & DerLig)
            .Interior.Color = RGB(250, 250, 250)
            .ClearContents
            .Borders.LineStyle = xlNone
        End With
    End If
End With
 
' lancement du tri
With ShDest
    DerLig = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    i = 2
    Rayon = Mid(.Cells(i, 1), 1, 1)
    ShSource.Range("C1").Value = "R" & Rayon & "0"
    Nbr_Tb = 6
 
    For i = i To DerLig - 1
        If Cells(i, 31) > 0 Then
            ShSource.Range("A" & Nbr_Tb).Value = .Cells(i, 1)
            .Range("B" & i).Copy ShSource.Range("B" & Nbr_Tb)
            .Range("I" & i).Copy ShSource.Range("C" & Nbr_Tb)
            .Range("AE" & i).Copy ShSource.Range("D" & Nbr_Tb)
            .Range("AK" & i).Copy ShSource.Range("E" & Nbr_Tb)
            ShSource.Range("F" & Nbr_Tb).Value = ShSource.Range("D" & Nbr_Tb) * ShSource.Range("E" & Nbr_Tb)
            .Range("M" & i).Copy ShSource.Range("G" & Nbr_Tb)
 
            For j = 13 To 24
                ShSource.Range("H" & Nbr_Tb).Value = ShSource.Range("H" & Nbr_Tb).Value + .Cells(i, j)
            Next j
 
            ShSource.Range("H" & Nbr_Tb).Value = ShSource.Range("H" & Nbr_Tb).Value / 12
 
            If ShSource.Cells(Nbr_Tb, 4) > (2 * ShSource.Cells(Nbr_Tb, 8)) Then
                ShSource.Cells(Nbr_Tb, 4).Interior.Color = RGB(250, 0, 0)
            End If
 
            Nbr_Tb = Nbr_Tb + 1
        End If
    Next i
End With
 
With ShSource
    .Range("A6:I" & Nbr_Tb).Sort Key1:=.Range("F6"), Order1:=xlDescending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
    DerLig = .Cells(.Rows.Count, 1).End(xlUp).Row
 
    With .Range("A6", "H" & DerLig)
        With .Borders
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
 
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
 
    With .Range(("B6"), .Range("B6").End(xlDown))
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
    End With
 
    .Range(("F6"), .Range("F6").End(xlDown)).Font.Bold = True
End With
Application.ScreenUpdating = True
End Sub

16/06/2015, 06h45
nuphius

Merci

pas facile de donner le fichier avec autant de données d'entreprise ...... mais vous m'avez déjà appris beaucoup de chose merci
16/06/2015, 07h03
SfJ5Rpw8

Bonjour,

Si ton classeur comporte beaucoup de formule,passe le en mode recalcul mnuel pendant tes copies...
16/06/2015, 09h46
joe.levrai

Bonjour,

tu peux facilement rendre tes données anonymes

utilise des "rechercher/remplacer" pour mélanger les lettres, ou les mots
supprime un peu de données (pas besoin de toutes les lignes de ta base de données par exemple)

et parfois, il suffit de quelques lignes totalement bidon pour comprendre ce que tu veux faire
il faut juste qu'on puisse conceptualiser et visualiser ce que tu fais, car ta macro étant très longue, on est obligé de tout décortiquer pour tout comprendre (pas pratique)
16/06/2015, 11h37
Marc-L

Dans un premier temps, oublier la mise en page, s'intéresser uniquement à la copie des données.

Détailler donc cette copie, s'il faut aussi conserver le format des cellules ou juste copier les valeurs …
17/06/2015, 21h45
nuphius

merci a tous pour votre aide je vais travailler tout cela