Macro qui fonctionne mais c'est trop lent

Version imprimable

Bonjour le forum,

J'ai un projet à faire en vba. Je suis vraiment débutante dans le domaine et je ne pense pas savoir coder d'une manière efficace. Pour faire ce bout de code, j'ai déjà parcouru d'innombrables forums et discussions.... bref...

Ma question est d'améliorer ce code qui fonctionne mais qui est étonnament lent. Avec quelques lignes pas de problème mais j'ai essayé avec une centaine c'est beaucoup trop lent (pourtant 100 lignes c'est pas énorme).
J'ai du me planter dans les boucles mais je ne voit pas comment améliorer ma synthaxe.

Ca donne :

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
Dim VALEUR1 As String, VALEUR2 As String
Dim VALEURA As String, VALEURB As String, VALEURC As String, VALEURD As String, VALEURE As String, VALEURF As String
Dim VALEURYE As String, VALEURYI As String
 
 ' je met des "*" pour définir les lignes à traiter car dans ma feuille le tableau est en liaison avec un autre classeur (classeur saisie de données) ce qui donne un tableau rempli de "0" qui correspondent aux données vides du classeur saisie de données)
 
For i = 3 To 143
VALEUR1 = Range("D" & i).Value
VALEUR2 = Range("R" & i).Value
    If VALEUR1 = "1" Then
    Range("A" & i) = "*"
    Else: Range("A" & i) = ""
    End If
    If VALEUR2 = "1" Then
    Range("O" & i) = "*"
    Else: Range("O" & i) = ""
    End If
 Next i
 
' je compare des données et je fait un marquage pour dire que ca correspond
c'est ICI que c'est super lent (on dirai)
 
For j = 3 To 143
For k = 3 To 143
VALEURA = Range("I" & j).Value
VALEURC = Range("L" & j).Value
VALEURE = Range("A" & j).Value
VALEURB = Range("W" & k).Value
VALEURD = Range("Z" & k).Value
VALEURF = Range("O" & k).Value
    If VALEURA = VALEURB And VALEURE = "*" And VALEURF = "*" Then
    Range("C" & j) = "1"
    Range("Q" & k) = "1"
    End If
    If VALEURC > VALEURD And VALEURE = "*" And VALEURF = "*" Then
    Range("B" & j) = "1"
    Range("P" & k) = "1"
    End If
Next
Next
 
' enfin je compile les infos qui correspondent dans un autre tableau
 
For l = 3 To 143
VALEURYE = Range("M" & l).Value
 
If VALEURYE = "Y" Then
Range(Cells(l, 4), Cells(l, 11)).Copy
Range(Cells(l, 31), Cells(l, 38)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next l
 
For m = 3 To 143
VALEURYI = Range("AA" & m).Value
 
If VALEURYI = "Y" Then
Range(Cells(m, 18), Cells(m, 25)).Copy
Range(Cells(m, 40), Cells(m, 47)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next m
 
' et je les trie
 
Range("AE4:AL143").Sort Key1:=Range("AK4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
Range("AM4:AT143").Sort Key1:=Range("AS4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
ActiveWindow.Visible = True
 
Set i = Nothing
Set j = Nothing
Set k = Nothing
Set l = Nothing
Set m = Nothing

Si quelqu'un à une idée, ne rier pas lol, je sais que c'est mal codé
Merci d'avance en tout cas

Met les bornes pour mettre ton code sur le forum (#) quand tu ecrit ton message:

Citation:

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
Dim VALEUR1 As String, VALEUR2 As String
Dim VALEURA As String, VALEURB As String, VALEURC As String, VALEURD As String, VALEURE As String, VALEURF As String
Dim VALEURYE As String, VALEURYI As String
 
' je met des "*" pour définir les lignes à traiter car dans ma feuille le tableau est en liaison avec un autre classeur (classeur saisie de données) ce qui donne un tableau rempli de "0" qui correspondent aux données vides du classeur saisie de données)
 
For i = 3 To 143
VALEUR1 = Range("D" & i).Value
VALEUR2 = Range("R" & i).Value
If VALEUR1 = "1" Then
Range("A" & i) = "*"
Else: Range("A" & i) = ""
End If
If VALEUR2 = "1" Then
Range("O" & i) = "*"
Else: Range("O" & i) = ""
End If
Next i
 
' je compare des données et je fait un marquage pour dire que ca correspond
c'est ICI que c'est super lent (on dirai)
 
For j = 3 To 143
For k = 3 To 143
VALEURA = Range("I" & j).Value
VALEURC = Range("L" & j).Value
VALEURE = Range("A" & j).Value
VALEURB = Range("W" & k).Value
VALEURD = Range("Z" & k).Value
VALEURF = Range("O" & k).Value
If VALEURA = VALEURB And VALEURE = "*" And VALEURF = "*" Then
Range("C" & j) = "1"
Range("Q" & k) = "1"
End If
If VALEURC > VALEURD And VALEURE = "*" And VALEURF = "*" Then
Range("B" & j) = "1"
Range("P" & k) = "1"
End If
Next
Next
 
' enfin je compile les infos qui correspondent dans un autre tableau
 
For l = 3 To 143
VALEURYE = Range("M" & l).Value
 
If VALEURYE = "Y" Then
Range(Cells(l, 4), Cells(l, 11)).Copy
Range(Cells(l, 31), Cells(l, 38)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next l
 
For m = 3 To 143
VALEURYI = Range("AA" & m).Value
 
If VALEURYI = "Y" Then
Range(Cells(m, 18), Cells(m, 25)).Copy
Range(Cells(m, 40), Cells(m, 47)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next m
 
' et je les trie
 
Range("AE4:AL143").Sort Key1:=Range("AK4"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
 
Range("AM4:AT143").Sort Key1:=Range("AS4"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
 
ActiveWindow.Visible = True
 
Set i = Nothing
Set j = Nothing
Set k = Nothing
Set l = Nothing
Set m = Nothing

Ensuite met

Code:

Application.ScreenUpdating=False 'au début

Code:

Application.ScreenUpdating=False 'à la fin

Si ton ecran clignote pendant l'execution ça va l'empecher et ça améliore la vitesse

Sinon je ne suis pas un expert alors pour le reste, je sais pas.

bon j'ai mis le screen updating en false puis en true, ca ne change pas grand chose

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
 
Dim VALEUR1 As String, VALEUR2 As String
Dim VALEURA As String, VALEURB As String, VALEURC As String, VALEURD As String, VALEURE As String, VALEURF As String
Dim VALEURYE As String, VALEURYI As String
 
Application.ScreenUpdating = False
 
For i = 3 To 143
VALEUR1 = Range("D" & i).Value
VALEUR2 = Range("R" & i).Value
    If VALEUR1 = "1" Then
    Range("A" & i) = "*"
    Else: Range("A" & i) = ""
    End If
    If VALEUR2 = "1" Then
    Range("O" & i) = "*"
    Else: Range("O" & i) = ""
    End If
 Next i
 
For j = 3 To 143
For k = 3 To 143
VALEURA = Range("I" & j).Value
VALEURC = Range("L" & j).Value
VALEURE = Range("A" & j).Value
VALEURB = Range("W" & k).Value
VALEURD = Range("Z" & k).Value
VALEURF = Range("O" & k).Value
    If VALEURA = VALEURB And VALEURE = "*" And VALEURF = "*" Then
    Range("C" & j) = "1"
    Range("Q" & k) = "1"
    End If
    If VALEURC > VALEURD And VALEURE = "*" And VALEURF = "*" Then
    Range("B" & j) = "1"
    Range("P" & k) = "1"
    End If
Next
Next
 
For l = 3 To 143
VALEURYE = Range("M" & l).Value
 
If VALEURYE = "Y" Then
Range(Cells(l, 4), Cells(l, 11)).Copy
Range(Cells(l, 31), Cells(l, 38)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next l
 
For m = 3 To 143
VALEURYI = Range("AA" & m).Value
 
If VALEURYI = "Y" Then
Range(Cells(m, 18), Cells(m, 25)).Copy
Range(Cells(m, 40), Cells(m, 47)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next m
 
Range("AE4:AL143").Sort Key1:=Range("AK4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
Range("AM4:AT143").Sort Key1:=Range("AS4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
 
ActiveWindow.Visible = True
 
Application.ScreenUpdating = True
 
Set i = Nothing
Set j = Nothing
Set k = Nothing
Set l = Nothing
Set m = Nothing

21/08/2009, 11h19
neiluj26
Tu n'aurais pas des formules de calcul dans d'autres cellules par hasard? Ca m'est arrivé une fois.

Dans ce cas, tu peux passer en calcul sur ordre ou utiliser:
Code:

1 2 3 4 5 'Au début du code Application.Calculation = xlCalculationManual 'A la fin du code Application.Calculation = xlCalculationAutomatic
21/08/2009, 11h30
lululaberlu

Alors la b...r...a...v...o,

C'est le jour et la nuit, car effectivement neiluj26, j'avais d'autres cellules avec des calculs.

C'est simple c'est 100 fois plus rapide :ccool:

Merci à diude54 et à neiluj26 pour leurs réponses rapides.

Peut etre devrai je mettre résolu plus tard, pour que d'autres solutions puissent etre postées.

Grand merci au forum
lululaberlu
21/08/2009, 11h42
mercatog
Ici
Code:

1 2 3 4 Range("P" & k) = "1" End If Next Next
ne faut il pas faire
Code:

1 2 Next k Next j
?

Question pour moi!
je croyais qu'avec une seule boucle on peut omettre le i mais avec des boucles imbriquées, on est obligé de spécifier!
peut être j'ai tort!

Re,

Petite précision quant même, dans cet exemple pour que ca marche, il faut bien placer le "Application.Calculation"

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
Dim VALEUR1 As String, VALEUR2 As String
Dim VALEURA As String, VALEURB As String, VALEURC As String, VALEURD As String, VALEURE As String, VALEURF As String, n As Integer, p As Integer
Dim VALEURYE As String, VALEURYI As String
    
Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual  
  
For i = 3 To 143
VALEUR1 = Range("D" & i).Value
VALEUR2 = Range("R" & i).Value
    If VALEUR1 = "1" Then
    Range("A" & i) = "*"
    Else: Range("A" & i) = ""
    End If
    If VALEUR2 = "1" Then
    Range("O" & i) = "*"
    Else: Range("O" & i) = ""
    End If
 Next i

For j = 3 To 143
For k = 3 To 143
VALEURA = Range("I" & j).Value
VALEURC = Range("L" & j).Value
VALEURE = Range("A" & j).Value
VALEURB = Range("W" & k).Value
VALEURD = Range("Z" & k).Value
VALEURF = Range("O" & k).Value
    If VALEURA = VALEURB And VALEURE = "*" And VALEURF = "*" Then
    Range("C" & j) = "1"
    Range("Q" & k) = "1"
    End If
    If VALEURC > VALEURD And VALEURE = "*" And VALEURF = "*" Then
    Range("B" & j) = "1"
    Range("P" & k) = "1"
    End If
Next
Next

Application.Calculation = xlCalculationAutomatic

For l = 3 To 143
VALEURYE = Range("M" & l).Value

If VALEURYE = "Y" Then
Range(Cells(l, 4), Cells(l, 11)).Copy
Range(Cells(l, 31), Cells(l, 38)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next l

For m = 3 To 143
VALEURYI = Range("AA" & m).Value

If VALEURYI = "Y" Then
Range(Cells(m, 18), Cells(m, 25)).Copy
Range(Cells(m, 40), Cells(m, 47)).PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
Next m

Range("AE4:AL143").Sort Key1:=Range("AK4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

Range("AM4:AT143").Sort Key1:=Range("AS4"), Order1:=xlAscending, Header:= _
        xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

ActiveWindow.Visible = True

Application.ScreenUpdating = True

Set i = Nothing
Set j = Nothing
Set k = Nothing
Set l = Nothing
Set m = Nothing

Voila et encore merci
N'hésitez pas à poster d'autres solutions pour rendre ce code plus rapide (à mon avis c'est possible tellement je code mal -déjà dit-)

21/08/2009, 11h46
neiluj26
Mon premier sujet résolu dis-donc! :D

Par contre, n'oublie pas d'ajouter un Calculate avant de repasser en calcul automatique, si tu as besoin que les cellules avec des calculs soient mises à jour:
Code:

1 2 3 Calculate Application.Calculation = xlCalculationAutomatic
21/08/2009, 11h48
lululaberlu

Salut mercatog,

Je ne pense pas que dans ce cas il y a besoin de spécifier, car une boucle est lancée puis une deuxième, les deux next arretent les boucles... et basta.

En tout cas ca marche
21/08/2009, 12h02
lululaberlu

Neiluj26,

Les cellules calculées se mettent automatiquement à jour car j'efface mes marquages par un "clearcontent" (que je n'ai pas affiché -pas pertinent-) au début de l'exécution de la macro. Donc la base du calcul est vierge à chaque fois que la macro est lancée.

Mais merci pour cette précision!

Sur ce je vais aller manger, je risque de faire d'autres discussions car j'ai d'autres problèmes...:aie: