Amélioration de la suppression de lignes spécifiques

**bizzzounours** · 22/05/2015, 11h08

Bonjour,

Après plusieurs recherches, j'avais fini par trouver une macro pour supprimer les lignes avec une cellule égales à une valeur spécifique (0 ou code ou vide) pour une colonne particulière.
Mais depuis quelques temps, la macro est très longue à s'exécuter (mini 15 min alors qu'avant c'était 1 min).

Voici ma macro (en rouge, la partie très longue):

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
Sub Erreur_sage()
Dim i As Integer

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Worksheets("Erreurs Sage").Range("A2:I100").ClearContents

Sheets("Erreurs Sage").Range("A2:I202").Value = Sheets("Livret").Range("A1:I201").Value
Sheets("Erreurs Sage").Range("A203:I283").Value = Sheets("Poste 9 regard+couv").Range("A1:I81").Value
Sheets("Erreurs Sage").Range("A284:I334").Value = Sheets("Poste 9 aspi").Range("A1:I51").Value
Sheets("Erreurs Sage").Range("A335:I405").Value = Sheets("Appuis").Range("A1:I71").Value
Sheets("Erreurs Sage").Range("A406:I446").Value = Sheets("Prélinteaux").Range("A1:I41").Value
Sheets("Erreurs Sage").Range("A447:I497").Value = Sheets("Poste 10 regards").Range("A1:I51").Value
Sheets("Erreurs Sage").Range("A498:I538").Value = Sheets("Poste 10 aspi").Range("A1:I41").Value
Sheets("Erreurs Sage").Range("A539:I589").Value = Sheets("Poste 11 regards").Range("A1:I51").Value
Sheets("Erreurs Sage").Range("A590:I630").Value = Sheets("Poste 11 aspi").Range("A1:I41").Value


With ThisWorkbook.Sheets("Erreurs Sage")

            For i = .Range("I" & .Rows.Count).End(xlUp).Row To 2 Step -1
                        If .Range("I" & i).Value = "0" Then
                                   .Rows(i).Delete
                        End If

            Next i
End With

With ThisWorkbook.Sheets("Erreurs Sage")

            For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
                        If .Range("A" & i).Value = "Code" Then
                                   .Rows(i).Delete
                        End If

            Next i
End With

With ThisWorkbook.Sheets("Erreurs Sage")

            For i = .Range("I" & .Rows.Count).End(xlUp).Row To 2 Step -1
                        If .Range("I" & i).Value = "" Then
                                   .Rows(i).Delete
                        End If

            Next i
End With
Sheets("Erreurs Sage").Columns("D:I").Delete Shift:=xlToLeft

Application .ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

Comment faire pour réduire le temps d’exécution?

Edit: J'ai vu qu'après qu'il y avait un sous-forum pour les macro VBA. Un modo pourrait il déplacer mon sujet au bon endroit? Car je ne vois pas comment supprimer mon sujet pour le recréer ailleurs.

**Efgé2** · 22/05/2015, 12h41

Bonjour bizzzounours

Essaie comme ça (une seule boucle au lieu de trois et mise en forme du code pour éviter des lignes inutiles)

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
Sub Erreur_sage_2()
Dim i As Long, Var As Variant
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("Erreurs Sage")
 
    .Range("A2:I100").ClearContents
 
    .Range("A2:I202").Value = Sheets("Livret").Range("A1:I201").Value
    .Range("A203:I283").Value = Sheets("Poste 9 regard+couv").Range("A1:I81").Value
    .Range("A284:I334").Value = Sheets("Poste 9 aspi").Range("A1:I51").Value
    .Range("A335:I405").Value = Sheets("Appuis").Range("A1:I71").Value
    .Range("A406:I446").Value = Sheets("Prélinteaux").Range("A1:I41").Value
    .Range("A447:I497").Value = Sheets("Poste 10 regards").Range("A1:I51").Value
    .Range("A498:I538").Value = Sheets("Poste 10 aspi").Range("A1:I41").Value
    .Range("A539:I589").Value = Sheets("Poste 11 regards").Range("A1:I51").Value
    .Range("A590:I630").Value = Sheets("Poste 11 aspi").Range("A1:I41").Value
 
    For i = .Range("I" & .Rows.Count).End(xlUp).Row To 2 Step -1
        Var = .Range("I" & i).Value
        If Var = "0" Or Var = "Code" Or Var = "" Then
            .Rows(i).Delete
        End If
    Next i
    .Columns("D:I").Delete Shift:=xlToLeft
End With
 
Application .ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
End Sub

**bizzzounours** · 22/05/2015, 13h30

Merci pour cette réponse rapide. Et j'ai oublié de préciser que je suis un débutant en VBA et pour être honnête, je ne comprend même pas la moitié de ma macro

Après test, la vitesse est la même.
Il faudrait peut être limité le nombre de ligne qu'il vérifie? Mes imports font environ 600 lignes.

**Efgé2** · 22/05/2015, 13h35

Il doit y avoir une autre chose, le temps de traitement devrait être diminué.
As tu des macros dans le module de la feuille "Erreurs Sage" de type évennementielle comme
Private Sub Worksheet_Change(ByVal Target As Range)

Si non on peux utiliser un tableau, ce qui devrait axélérer les choses de manière significative:

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
Sub Erreur_sage_3()
Dim i&, J&, K&
Dim Var As Variant, T As Variant
Dim Rng As Range
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("Erreurs Sage")
 
    .Range("A2:I100").ClearContents
 
    .Range("A2:I202").Value = Sheets("Livret").Range("A1:I201").Value
    .Range("A203:I283").Value = Sheets("Poste 9 regard+couv").Range("A1:I81").Value
    .Range("A284:I334").Value = Sheets("Poste 9 aspi").Range("A1:I51").Value
    .Range("A335:I405").Value = Sheets("Appuis").Range("A1:I71").Value
    .Range("A406:I446").Value = Sheets("Prélinteaux").Range("A1:I41").Value
    .Range("A447:I497").Value = Sheets("Poste 10 regards").Range("A1:I51").Value
    .Range("A498:I538").Value = Sheets("Poste 10 aspi").Range("A1:I41").Value
    .Range("A539:I589").Value = Sheets("Poste 11 regards").Range("A1:I51").Value
    .Range("A590:I630").Value = Sheets("Poste 11 aspi").Range("A1:I41").Value
 
    Set Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(3)(1, 9))
    T = Rng
    For i = LBound(T, 1) To UBound(T, 1)
        Var = T(i, 9)
        If Var <> "0" And Var <> "Code" And Var <> "" Then
            J = J + 1
            For K = LBound(T, 2) To UBound(T, 2)
                T(J, K) = T(i, K)
            Next K
        End If
    Next i
    Rng.ClearContents
    Rng.Resize(J, UBound(T, 2)) = T
    .Columns("D:I").Delete Shift:=xlToLeft
End With
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
End Sub

**Menhir** · 22/05/2015, 14h44

Juste pour remplacer la partie rouge

Code :

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

1
2
3
4
ThisWorkbook.Sheets("Erreurs Sage").Activate
For i = Range("I" & .Rows.Count).End(xlUp).Row To 2 Step -1
   If Cells(i,9) = "0" or Cells(i,9) = "" or Cells(i,1) = "Code" or Then Rows(i).Delete
Next i

Si tu peux te permettre de modifier l'ordre des ligne, il est possible aussi de commencer par un tri suivit de deux recherches (pour délimiter la zone) et supprimer toutes les lignes d'un coup.

**bizzzounours** · 22/05/2015, 14h44

C'est parfait, merci Efgé2. Même pas 5 secondes maintenant XD

Non je n'ai pas de module dans la feuille erreur sage.
Bon maintenant, il faut juste que j'arrive à transposer ça pour mes 2 autres module^^

**bizzzounours** · 22/05/2015, 14h51

Menhir,
J'ai une erreur ici ("I" & .Rows.Count) avec ton code.
Celui de Efgé2 fonctionne très bien alors c'est résolu

**Menhir** · 22/05/2015, 15h05

Mon code remplace toute ta partie rouge (les trois boucles).
Dans le reste de ton code, il n'y a pas de .Row.
Tu n'as donc pas remplacé la bonne partie.

**bizzzounours** · 22/05/2015, 15h16

Pour mes autres modules, quels sont les choses que je dois modifier?

Juste le 9 pour le nombre de range?
Que représente Set Rng = .Range(.Cells(2, 1), et .Cells(.Rows.Count, 1).End(3)(1, 9)) ?

**Efgé2** · 22/05/2015, 15h40

Cells(Ligne, colonne)
Donc Cells(2, 1) est la cellule A2 (début du tableau ligne 2 colonne 1)

Ensuite
.Cells(.Rows.Count, 1).End(3) est la cellule la plus basse en colonne 1 (A)
On la cherche depuis la dernière ligne de la feuille (.Rows.count) et en remontant (c'est le (3))
Ensuite, comme on a 9 colonnes on décale la dernière cellule trouvée en colonne A de 9 colonnece qui donne la colonne I.(c'est le (1,9) )

Donc .Range(.Cells(2, 1), et .Cells(.Rows.Count, 1).End(3)(1, 9)) te donne l'ensemble du tableau ou se trouvent les données de la feuille

**vinc_bilb** · 22/05/2015, 15h48

Bonjour,

Si besoin, il y a encore plus rapide:
- Vous filtrez les données pour afficher celles que vous voulez supprimer
- Vous récupérez celles qui sont visibles par Range.SpecialCellsxlCellTypeVisible

=> Suppression en 1 passe!

Vous pouvez passer les paramètres de filtrage, par exemple:

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Sub AutoFilter_by_ArrayParam()
Dim Wks As Worksheet	
On Error GoTo Err_Filter	
Dim arCriteria(0 To 1) As String	
 
Set Wks = ActiveSheet	
arCriteria(0) = "Loeb"	
arCriteria(1) = "Vettel"	
 
Wks.UsedRange.AutoFilter Field:=2, Criteria1:=arCriteria, Operator:=xlFilterValues
 
Err_Filter:	
If Err <> 0 Then (...)

**Menhir** · 22/05/2015, 16h05

Envoyé par bizzzounours

Pour mes autres modules, quels sont les choses que je dois modifier?

Je répète ce que j'ai déjà écrit : mes 4 lignes de code remplacent TOUTE la partie rouge de ton code, c'est-à-dire LES 3 BOUCLES incluses dans LES 3 WITH. C'est tout l'intérêt du Or dans le If.

**bizzzounours** · 26/05/2015, 11h24

J'ai bien compris menhir mais, il y a des erreurs (or devant le then; manque le end if) et la vitesse est pratiquement la même. C'est dommage car je comprend bien mieux ce code.

J'ai essayé d'adapter celui d'Efgé2:

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
Sub Rapport()
Dim i&, J&, K&
Dim Var As Variant, T As Variant
Dim Rng As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

With ThisWorkbook.Sheets("Rapport")

    Range("A1").ClearContents

    Range("C2:F202").Value = Sheets("Livret").Range("E1:H201").Value
    Range("C203:F283").Value = Sheets("Poste 9 regard+couv").Range("C1:F81").Value
    Range("C284:F334").Value = Sheets("Poste 9 aspi").Range("C1:F51").Value
    Range("C335:F405").Value = Sheets("Appuis").Range("D1:G90").Value
    Range("C406:F446").Value = Sheets("Prélinteaux").Range("D1:I41").Value
    Range("C447:F497").Value = Sheets("Poste 10 regards").Range("C1:F51").Value
    Range("C498:F538").Value = Sheets("Poste 10 aspi").Range("C1:F41").Value
    Range("C539:F589").Value = Sheets("Poste 11 regards").Range("C1:F51").Value
    Range("C590:F630").Value = Sheets("Poste 11 aspi").Range("C1:F41").Value


    Set Rng = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(3)(3, 6))
    T = Rng
    For i = LBound(T, 1) To UBound(T, 1)
        Var = T(i, 6)
        If Var <> "0" And Var <> "" Then
            J = J + 1
            For K = LBound(T, 2) To UBound(T, 2)
                T(J, K) = T(i, K)
            Next K
        End If
    Next i
    Rng.ClearContents
    Rng.Resize(J, UBound(T, 2)) = T

End With

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

mais j'ai une erreur là : Rng.Resize(J, UBound(T, 2)) = T

D'ailleurs (dans son 1er code) quand il met If Var <> "0" And Var <> "Code" And Var <> "" Then ça vérifie les cellules que dans la colonne I? Car j'ai besoin de trier, "code" que pour la colonne A puis "0" et "" que pour la colonne I. J'ai test ça:

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
For i = LBound(T, 1) To UBound(T, 1)
        Var = T(i, 9)
        If Var <> "0" And Var <> "" Then
            J = J + 1
            For K = LBound(T, 2) To UBound(T, 2)
                T(J, K) = T(i, K)
            Next K
        End If
    Next i
    
        For i = LBound(T, 1) To UBound(T, 1)
        Var = T(i, 1)
        If Var <> "Code" Then
            J = J + 1
            For K = LBound(T, 2) To UBound(T, 2)
                T(J, K) = T(i, K)
            Next K
        End If
    Next i
    Rng.ClearContents

Mais j'ai une erreur sur le deuxième T(J, K) = T(i, K)

vinc_bilb c'est surement sympa mais, comme je l'ai dit, je suis un pur débutant donc j'aurai dû mal à mettre ça en place (déjà que je galère avec celui d'Efgé2 ^^')

**Menhir** · 26/05/2015, 11h41

Envoyé par bizzzounours

J'ai bien compris menhir mais, il y a des erreurs (or devant le then; manque le end if)

Le dernier Or est effectivement une erreur de copier/coller.
En revanche, le End If ne doit pas être ajouté si l'action du If se limite à une ligne et se trouve sur la même ligne que celui-ci (comme c'est le cas ici).

Par exemple :

Code :

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

If a=0 Then b=1

est une syntaxe tout aussi valide que.

Code :

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

1
2
3
If a=0 Then 
   b=1
End If

Ca évite d'ouvrir une structure qui ralentit un peu l'exécution.

**bizzzounours** · 26/05/2015, 11h53

Ah OK.

J'ai retest avec:

Code :

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

1
2
3
4
  For i = .Range("I" & .Rows.Count).End(xlUp).Row To 2 Step -1
                    If .Cells(i, 9) = "0" Or .Cells(i, 9) = "" Or .Cells(i, 1) = "Code" Then .Rows(i).Delete
 
        Next i

Mais l'amélioration n'est pas visible.

**Efgé2** · 26/05/2015, 12h31

Bonjour

Les modifications demandées.
Si il y a un stop sur la ligne

Code :

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

Rng.Resize(J, UBound(T, 2)) = T

C'est peut-être que toutes les lignes doivent être supprimées.
J'ai ajouté une condition pour vérifier cette situation:

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
Sub Erreur_sage_4()
Dim i&, J&, K&
Dim Var As Variant, T As Variant
Dim Rng As Range
 
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook.Sheets("Erreurs Sage")
 
    .Range("A2:I100").ClearContents
 
    .Range("A2:I202").Value = Sheets("Livret").Range("A1:I201").Value
    .Range("A203:I283").Value = Sheets("Poste 9 regard+couv").Range("A1:I81").Value
    .Range("A284:I334").Value = Sheets("Poste 9 aspi").Range("A1:I51").Value
    .Range("A335:I405").Value = Sheets("Appuis").Range("A1:I71").Value
    .Range("A406:I446").Value = Sheets("Prélinteaux").Range("A1:I41").Value
    .Range("A447:I497").Value = Sheets("Poste 10 regards").Range("A1:I51").Value
    .Range("A498:I538").Value = Sheets("Poste 10 aspi").Range("A1:I41").Value
    .Range("A539:I589").Value = Sheets("Poste 11 regards").Range("A1:I51").Value
    .Range("A590:I630").Value = Sheets("Poste 11 aspi").Range("A1:I41").Value
 
    Set Rng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(3)(1, 9))
    T = Rng
    For i = LBound(T, 1) To UBound(T, 1)
        Var = T(i, 9)
        If Var <> "0" And Var <> "" And T(i, 1) <> "Code" Then
            J = J + 1
            For K = LBound(T, 2) To UBound(T, 2)
                T(J, K) = T(i, K)
            Next K
        End If
    Next i
    Rng.ClearContents
    If J > 0 Then Rng.Resize(J, UBound(T, 2)) = T
    .Columns("D:I").Delete Shift:=xlToLeft
End With
 
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
End Sub

Cordialement

Amélioration de la suppression de lignes spécifiques [XL-2013]

Excel

Discussions similaires

Partager

Partager