Macro lente suppression de ligne sous conditions

Acturis

XLDnaute Nouveau
Bonjour à tous,

J'ai cherché sur le forum une macro permettant de supprimer des lignes si une cellule contient une certaine valeur.

Je suis tombé sur un fil proposant ce code :

VB:
Sub Filter()
Dim i As Long
With Sheets("DATA")
For i = Range("U20000").End(xlUp).Row To 2 Step -1
If Cells(i, 21) Like "To delete" Then Rows(i).Delete
Next i
End With
End Sub
Cette Macro fonctionne bien, cependant comme j'ai presque 20000 lignes à vérifier, mon pc s'emballe et la macro met vraiment énormément de temps à s’exécuter.

Quelqu'un aurait il une astuce pour accélérer le processus ? En changeant peut être la logique "For".

Merci d'avance pour votre aide
 

Jauster

XLDnaute Occasionnel
Bonjour,
A essayer : En désactivant quelques fonctions puis en les réactivant à la fin :
VB:
Sub Filter()
Dim i As Long
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False

With Sheets("DATA")
    For i = Range("U20000").End(xlUp).Row To 2 Step -1
        If Cells(i, 21) Like "To delete" Then Rows(i).Delete
    Next i
End With

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
End Sub
 

vgendron

XLDnaute Barbatruc
Hello
un essai avec ceci
VB:
Sub Filter()

With Sheets("DATA").UsedRange
    .AutoFilter
    .AutoFilter Field:=21, Criteria1:="=To Delete"
    .Offset(1).SpecialCells(xlCellTypeVisible).Delete
    .AutoFilter
End With
End Sub
 

Jauster

XLDnaute Occasionnel
Hello Vgendron, Re Acturis,

A essayer :
VB:
Sub Test()

Dim supprRng As Range, Rng As Range, cell As Range

With Sheets("Data")
    Set Rng = .Range(.Cells(2, "U"), .Cells(.Rows.Count, "U").End(xlUp))
End With

For Each cell In Rng.Cells
    If cell.Value2 = "To Delete" Then
        If supprRng Is Nothing Then
            Set supprRng = cell
        Else
            Set supprRng = Union(supprRng, cell)
        End If
    End If
Next

If Not supprRng Is Nothing Then supprRng.EntireRow.Delete

End Sub
Testé sur 15000 lignes en 1.8 secondes
testtt.PNG
 

Acturis

XLDnaute Nouveau
Bonjour,

Merci à vous deux pour votre réponse rapide =).
La macro de vgendron est vraiment très rapide ! C'est top ! Par contre excel affiche le message "Voulez vous supprimer la ligne" et il faut cliquer sur "Oui". Est-ce possible de ne pas afficher ce message ?
En tout cas merci beaucoup.
 

Fichiers joints

Jauster

XLDnaute Occasionnel
Re,

En ajoutant
Application.DisplayAlerts = False au début de la macro et
Application.DisplayAlerts = True en fin de macro
 

vgendron

XLDnaute Barbatruc
Pour ne pas avoir le message d'alerte
VB:
Sub Filter()
Application.DisplayAlerts = False

With Sheets("DATA").UsedRange
    .AutoFilter
    .AutoFilter Field:=21, Criteria1:="=To Delete"
    .Offset(1).SpecialCells(xlCellTypeVisible).Delete
    .AutoFilter
End With
Application.DisplayAlerts = True
End Sub
 

Jauster

XLDnaute Occasionnel
Pour ne pas avoir le message d'alerte
VB:
Sub Filter()
Application.DisplayAlerts = False

With Sheets("DATA").UsedRange
    .AutoFilter
    .AutoFilter Field:=21, Criteria1:="=To Delete"
    .Offset(1).SpecialCells(xlCellTypeVisible).Delete
    .AutoFilter
End With
Application.DisplayAlerts = True
End Sub
Du coup UsedRange n'est pas limité ici ? J'ai l'impression que c'était juste pour m’énerver la dernière fois^^
 

vgendron

XLDnaute Barbatruc
Du coup UsedRange n'est pas limité ici ? J'ai l'impression que c'était juste pour m’énerver la dernière fois^^
@Jauster vu qu'on a pas de fichier exemple ici pour tester, j'ai fait le test sur 10 lignes.. donc peu de chance que ca bug
et j'avais la flemme d'écrire une ligne de plus pour avoir la dernière ligne.. :-D
 

Acturis

XLDnaute Nouveau
Je viens de faire le test sur 15000 lignes et pas de bug =)
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas