Problème temps d'exécution lors de la suppression d'enregistrement

**juju05** · 22/12/2011, 09h11

Bonjour,

Je suis débutant en VBA Excel.

J'ai créé une macro. qui :
- balaye un ensemble de lignes et met en rouge les cellules de la colonne J lorsque sa valeur est à "x",
- supprime la ligne lorsque la valeur de la cellule de la colonne L est à "x",
- trie par une partie de la colonne F puis je prends l'intégralité de mon tableau,
-met des bordures sur l'ensemble de mon tableau.

Je dois mal m'y prendre car le temps d'exécution est bien trop long.
J'ai essayé de geler l'écran et le calcul automatique avant puis les réactiver après mais cela ne donne pas grand chose.

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
Dim lastlig As Long
 
   Dim ligne_traitee As Long
 
   ' Détermination de la dernière ligne de la feuille 1 (Prépa. palette)
   Worksheets("Prepa palette").Activate
   With Worksheets("Prepa palette")
        lastlig = .Cells(.Rows.Count, "E").End(xlUp).Row
   End With
 
   ligne_traitee = 4
 
   Do Until ligne_traitee = lastlig
 
      Range("J" & ligne_traitee).Select
      If Selection.Value = "x" Then
         With Selection.Interior
          .ColorIndex = 3
          .Pattern = xlSolid
         End With
      End If
 
      If Range("K" & ligne_traitee) = "x" Then
         Rows(ligne_traitee).EntireRow.Delete Shift:=xlUp
      Else
         ligne_traitee = ligne_traitee + 1
      End If
   Loop
 
   ' Récupération de la dernière ligne après suppression
   Worksheets("Prepa palette").Activate
   With Worksheets("Prepa palette")
        lastlig = .Cells(.Rows.Count, "E").End(xlUp).Row
   End With
 
   ' Tri par date de livraison croissante
   Range("F3:F" & lastlig).Select
   Selection.Sort Key1:=Range("F3"), Order1:=xlAscending, Header:=xlGuess, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
   ' Mise en gras de la colonne de date de livraison.
   Range("F3:F" & lastlig).Select
   Selection.Font.Bold = True
 
   ' Remise des bordures sur l'ensemble des cellules
   Range("A4:L" & lastlig).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
 
 
   MsgBox "Suppression terminée!"

Merci d'avance de votre aide.
Julien.

**ZebreLoup** · 22/12/2011, 10h30

Une première remarque, tu devrais peut-être parcourir les lignes en partant de la dernière, car pour le moment, si par exemple tu as effacé 50 lignes, ton algorithme continue à s'éxécuter sur 50 lignes de trop à la fin. Ou alors tu fais un

Code :

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

lastlig = lastlig - 1

Ensuite, plutôt que de faire un select, travaille directement sur le range

Code :

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

1
2
3
4
5
6
With Range("J" & ligne_traitee)
  If .Value = "x" Then
    .Interior.ColorIndex = 3
    .Interior.Pattern = xlSolid
  End If
End With

Mais il y a combien de lignes ? Parce que si tu mets screenUpdating à False et Calculation en manuel, ça devrait aller assez vite.
Il n'y a pas d'évènement Worksheet_Change sur ton classeur ?

**juju05** · 22/12/2011, 12h07

Je ne comprends pas pourquoi c'est si lent. Je n'ai que 300 lignes sur ma feuille.

Voici mon nouveau code, cela va un peu plus vite mais ce n'est pas le top.
Le bouton est positionné sur la feuille en question. J'ai d'autres macro. sur le classeur qui se positionnent tour à tour sur d'autres feuilles.

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
' Cette macro. a pour objectifs de :
   ' - Supprimer les O.F. importés pour lesquels le responsable du secteur soudure n'a pas la fiche suiveuse (en supprimant les lignes cochées "x" dans la colonne "Importé"
   ' - Trier la colonne date de livraison de manière croissante (des O.F. les plus anciens aux plus récents),
   ' - Mettre en gras les dates de livraison.
 
 
   Dim lastlig As Long
 
   Dim ligne_traitee As Long
 
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
 
   ' Détermination de la dernière ligne de la feuille 1 (Prépa. palette)
   Worksheets("Prepa palette").Activate
   With Worksheets("Prepa palette")
        lastlig = .Cells(.Rows.Count, "E").End(xlUp).Row
   End With
 
   ligne_traitee = lastlig
 
   Do Until ligne_traitee = 3
 
 
      With Range("J" & ligne_traitee)
           If .Value = "x" Then
              .Interior.ColorIndex = 3
              .Interior.Pattern = xlSolid
              .Font.Bold = True
              .Font.ColorIndex = 2
           End If
      End With
 
 
      If Range("K" & ligne_traitee) = "x" Then
         Rows(ligne_traitee).EntireRow.Delete
      End If
      ligne_traitee = ligne_traitee - 1
 
   Loop
 
   ' Récupération de la dernière ligne après suppression
   Worksheets("Prepa palette").Activate
   With Worksheets("Prepa palette")
        lastlig = .Cells(.Rows.Count, "E").End(xlUp).Row
   End With
 
   ' Tri par date de livraison croissante
   Range("F3:F" & lastlig).Select
   Selection.Sort Key1:=Range("F3"), Order1:=xlAscending, Header:=xlGuess, _
   OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
 
   ' Mise en gras de la colonne de date de livraison.
   Range("F3:F" & lastlig).Select
   Selection.Font.Bold = True
 
   ' Remise des bordures sur l'ensemble des cellules
   Range("A4:L" & lastlig).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
 
   Application.ScreenUpdating = True
   Application.Calculation = xlCalculationAutomatic
 
   MsgBox "Suppression terminée!"

**mercatog** · 22/12/2011, 13h45

Évite les Select

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
Sub Test()
Dim LastLig As Long, i As Long
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Prepa palette")
    LastLig = .Cells(.Rows.Count, "E").End(xlUp).Row
    For i = LastLig To 4 Step -1
        If .Range("K" & i) = "x" Then
            .Rows(i).Delete
            LastLig = LastLig - 1
        ElseIf .Range("J" & i).Value = "x" Then
            With .Range("J" & i)
                .Interior.ColorIndex = 3
                .Interior.Pattern = xlSolid
                .Font.Bold = True
                .Font.ColorIndex = 2
            End With
        End If
    Next i
    ' Tri par date de livraison croissante
    .Range("F3:F" & LastLig).Sort Key1:=.Range("F3"), Order1:=xlAscending, Header:=xlYes
    ' Mise en gras de la colonne de date de livraison.
    .Range("F3:F" & LastLig).Font.Bold = True
 
    ' Remise des bordures sur l'ensemble des cellules
    With .Range("A4:L" & LastLig).Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
End With
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "Suppression terminée!"
End Sub

**juju05** · 22/12/2011, 14h01

Merci beaucoup, cela va plus vite et surtout c'est bien codé !

Problème temps d'exécution lors de la suppression d'enregistrement [XL-2000]

Macros et VBA Excel

Discussions similaires

Partager

Partager