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
 

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.
 

Pièces jointes

  • Capture.PNG
    Capture.PNG
    23.4 KB · Affichages: 34

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^^
 

Discussions similaires

Réponses
15
Affichages
427

Statistiques des forums

Discussions
311 723
Messages
2 081 932
Membres
101 844
dernier inscrit
pktla