optimisation de macro vba

Version imprimable

Bonjour tlm,

je suis un debutant de plus en vb soyé indulgent lol !
voila j'ai une feuille qui contient des données 4000 ligne et 10 colonnes
mon but est de trié ces données dans des sheets differents en fonction de la valeur de deux colonnes.

a l'heure actuel la macro prend 250s pour ces 4000 lignes a terme je pourrai en avoir 10 à 15000.

si dessous le scripte utilisé :

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
Sub EXT_stats()
 
Dim d As Integer
 
For d = 3 To 7
 
Worksheets("sheet" & d).Visible = 1
 
Next d
 
    Sheets("data_brut").Select
    ' Find the last row of data
 
    FinalRow = Range("B65536").End(xlUp).Row
 
    For x = 1 To FinalRow
 
        Status = Cells(x, 1).Value
        TypeFile1 = Cells(x, 5).Value
        TypeFile2 = Cells(x, 5).Value
        TypeFile3 = Cells(x, 5).Value
 
        If Status = "IN OK" And TypeFile1 = "TITI" Then
            Cells(x, 1).Resize(1, 10).Copy
            Sheets("Sheet3").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("data_brut").Select
 
        ElseIf Status = "OUT OK" And TypeFile2 = "TOTO" Then
            Cells(x, 1).Resize(1, 10).Copy
            Sheets("Sheet4").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("data_brut").Select
 
        ElseIf Status = "OUT OK" And TypeFile3 = "TUTU" Then
            Cells(x, 1).Resize(1, 10).Copy
            Sheets("Sheet5").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("data_brut").Select
 
         ElseIf Status = "IN OK" And TypeFile3 = "TATA" Then
            Cells(x, 1).Resize(1, 10).Copy
            Sheets("Sheet6").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("data_brut").Select
 
         ElseIf Status = "IN OK" And TypeFile3 = "TETE" Then
            Cells(x, 1).Resize(1, 10).Copy
            Sheets("Sheet7").Select
            NextRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
            Cells(NextRow, 1).Select
            Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
            Sheets("data_brut").Select
 
 
        End If
 
      Next x
 
   Sheets("EXT_stats").Select
 
End Sub

Bonjour,

Une instruction toute simple permet de gagner beaucoup de temps d'exécution d'une macro : Application.ScreenUpdating = False. Cela évite qu'Excel rende visible tous les changements d'onglets et de fichiers.
En mettant Application.ScreenUpdating = False au début de la procédure et Application.ScreenUpdating = True à la fin, je passe de 1'16 à 0'11 de temps d'exécution.

Le code peut aussi être optimisé, cela ne change pas la performance mais permet de rendre la maintenance plus facile :

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
Sub EXT_stats()
 
Dim d As Integer
Dim strSheet As String
Dim strTypeFile As String
Dim strStatus As String
Dim lngFinalRow As Long
Dim x As Long
Dim celDestination As Range
 
    Debug.Print "Début : " & Time
    For d = 3 To 7
        Worksheets("sheet" & d).Visible = 1
    Next d
 
    Sheets("data_brut").Select
    ' Find the last row of data
    lngFinalRow = Range("B65536").End(xlUp).Row
    Application.ScreenUpdating = False
 
    For x = 1 To lngFinalRow
        Application.StatusBar = x & "/" & lngFinalRow
 
        strStatus = Cells(x, 1).Value
        strTypeFile = Cells(x, 5).Value
        strSheet = vbNullString
 
        If strStatus = "IN OK" Then
            If strTypeFile = "TITI" Then
                strSheet = "Sheet3"
            ElseIf strTypeFile = "TATA" Then
                strSheet = "Sheet6"
            ElseIf strTypeFile = "TETE" Then
                strSheet = "Sheet7"
            End If
 
        ElseIf strStatus = "OUT OK" Then
            If strTypeFile = "TOTO" Then
                strSheet = "Sheet4"
            ElseIf strTypeFile = "TUTU" Then
                strSheet = "Sheet5"
            End If
        End If
 
        If strSheet <> vbNullString Then
            Range("A" & x & ":J" & x).Copy
            Set celDestination = Sheets(strSheet).Cells(Sheets(strSheet).Cells(Sheets(strSheet).Rows.Count, 1).End(xlUp).Row + 1, 1)
            celDestination.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        End If
    Next x
 
    Application.StatusBar = False
    Application.ScreenUpdating = False
    Sheets("EXT_stats").Select
    Debug.Print "Fin : " & Time
 
End Sub

Dans ce code j'ai supprimé les .Select inutiles.

14/01/2013, 08h30
Lulux57

Merci tedo,
j'ai ajouté la fonction Application.ScreenUpdating effectivement ça vas deja beaucoup mieux.
Je vais etudier ton optimisation, je decortique beaucoup pour bien comprendre ce que je fais, et maintenant je passe à l'etape superieur.
Je tiens informé le poste et je pense que je peux le flager comme résolu ? :ccool: