Microsoft 365 [RESOLU] Supprimer Ligne rapidement et avec plusieurs conditions

[BENAM69]

Bonjour à tous

Je me permets d'ouvrir cette discussion car je n'ai pas réussi à trouver mon erreur même en cherchant sur les discussions.

Voici un 1er code test :

Sub test()

Worksheets("Extraction 1").Activate
Application.ScreenUpdating = True
Dim I
For I = ActiveSheet.Range("A50000").End(xlUp).Row To 2 Step -1
Application.ScreenUpdating = True
If Cells(I, 2).Value <> "JOJO" _
Or Cells(I, 2).Value <> "LOLO" _
Or Cells(I, 2).Value <> "LILA" _
Or Cells(I, 2).Value <> "LILI" _
Or Cells(I, 2).Value <> "CHACHA" _
Or Cells(I, 2).Value <> "LALA" _
Or Cells(I, 2).Value <> "TATA" _
Or Cells(I, 2).Value <> "TOTO" _
Or Cells(I, 2).Value <> "TITI" _
Then Rows(I).Delete
Application.ScreenUpdating = True
Next
Application.ScreenUpdating = True
End Sub

Voici le 2ème code test : Celui-ci est avec not et like

Sub test_2()

Worksheets("Extraction 1").Activate
Application.ScreenUpdating = True
Dim I
For I = ActiveSheet.Range("A50000").End(xlUp).Row To 2 Step -1
Application.ScreenUpdating = True
If Not Cells(I, 2).Value Like "*JOJO*" _
Or Not Cells(I, 2).Value Like "*LOLO*" _
Or Not Cells(I, 2).Value Like "*LILA*" _
Or Not Cells(I, 2).Value Like "*LILI*" _
Or Not Cells(I, 2).Value Like "*CHACHA*" _
Or Not Cells(I, 2).Value Like "*LALA*" _
Or Not Cells(I, 2).Value Like "*TATA*" _
Or Not Cells(I, 2).Value Like "*TOTO*" _
Or Not Cells(I, 2).Value Like "*TITI*" _
Then Rows(I).Delete
Application.ScreenUpdating = True
Next
Application.ScreenUpdating = True
End Sub

Je n'arrive pas à supprimer mes 45000 lignes rapidement, cela me prend beaucoup de temps. Et le fichier bug, elle reste figée pendant longtemps.
Si en colonne A, la cellule ne contient pas l'une des 7 références, alors elle supprime toute la ligne.

1er problème :
Le temps d'exécution est trop longue
2ème problème :
Elle me supprime parfois certaines références mentionnées.

Je vous remercie par avance de votre aide.

Ci-joint le fichier.
Onglet : Extraction 1

J'ai du supprimer des lignes car il est trop volumineux pour que je ne mette ici (Le fichier d'attache n'est pas accepté) , mais il y en a beaucoup plus sur le fichier original. Soit environs 45000 lignes

BeNam

 

[scraper]

Bonjour BENAM69
Prends un bon café ca ira mieux
Les valeurs de la colonne A ne sont pas testées avec Cells(I, 2).Value mais avec Cells(I, 1).Value

 

[BENAM69]

Bonjour scraper

Aurais-tu une corde pour moi stp que je me pende ?
Merci pour ton coup d'oeil ^^

Je viens de le tester, cela devrait fonctionner avec Cells(I, 1).Value.
Mais elle est très lente, aurais-tu une solution pour que cela aille plus vite stp ?
Ma macro supprime toutes les données de la ligne mais ne supprime pas la ligne.
BeNam69

 

[BENAM69]

Hello

J'ai ajouté Shift:=xlUp réalisé comme ci-joint et cela marche, je pense que le nombre de ligne y est pour beaucoup, doncil n'y a pas vraiment de solution :

Sub test()

Worksheets("Extraction 1").Activate
Application.ScreenUpdating = False
Dim I
For I = ActiveSheet.Range("A50000").End(xlUp).Row To 2 Step -1
Application.ScreenUpdating = False
If Cells(I, 1).Value <> "JOJO" _
Or Cells(I, 1).Value <> "LOLO" _
Or Cells(I, 1).Value <> "LILA" _
Or Cells(I, 1).Value <> "LILI" _
Or Cells(I, 1).Value <> "CHACHA" _
Or Cells(I, 1).Value <> "LALA" _
Or Cells(I, 1).Value <> "TATA" _
Or Cells(I, 1).Value <> "TOTO" _
Or Cells(I, 1).Value <> "TITI" _
Then Rows(I).Delete Shift:=xlUp
Application.ScreenUpdating = False
Next
Application.ScreenUpdating = False
End Sub

Merci c'est résolu
Je vais clôturer le sujet

A+

BeNam

 

[sylvanu]

Bonjour Benam, Scraper,
Une autre approche en PJ, qui s'est révélée à de multiples reprises la solution la plus rapide, avec :

Sub SuppLignes()
T0 = Timer  ' A supprimer, juste pour mesurer le temps
    Dim DL, f
    Application.ScreenUpdating = False                  ' On fige l'écran
    DL = [A100000].End(xlUp).Row                         ' Dernière ligne de Résultat
    Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove ' Insertion colonne en A
    ' Formule à implémenter ( attention incrémenter N) colonne de 1 à cause de la colonne insérer à gauche )
    f = "=SI(OU(ESTNUM(CHERCHE(""JOJO""; C2));ESTNUM(CHERCHE(""LOLO""; C2));ESTNUM(CHERCHE(""LILA""; C2));ESTNUM(CHERCHE(""LILI""; C2));ESTNUM(CHERCHE(""TITI""; C2));ESTNUM(CHERCHE(""CHACHA""; C2));ESTNUM(CHERCHE(""LALA""; C2));ESTNUM(CHERCHE(""TOTO""; C2));ESTNUM(CHERCHE(""TATA""; C2)))=FAUX;CAR(1);0)"
    With Range("A2:A" & DL)                             ' Plage où coller la formule en colonne A qui sera triée
        .FormulaLocal = f                               ' Coller formule
        .EntireRow.Sort .Cells, xlDescending            ' Tri pour regrouper et accélérer
        On Error Resume Next
        .SpecialCells(xlCellTypeFormulas, 2).EntireRow.Delete  ' Suppression des lignes concernées
    End With
    Columns("A:A").Delete Shift:=xlToLeft               ' Suppression colonne A ajoutée
    ' Columns.AutoFit                                   'Ajustement largeurs colonnes, à mettre si désiré
    With ActiveSheet.UsedRange: End With                'Ajustement barres de défilement
    Application.ScreenUpdating = True
[AA1] = Format(Timer - T0, "0.000s") ' A supprimer
End Sub

Dans la PJ appuyer sur le bouton gris qui copie le tableau de données ( 47000 lignes ) puis sur le bouton bleu pour faire le boulot.
Sur mon vieux PC avec Xl2007, pour 47k lignes, cela met autour de 1.5s.

NB: Dans le code il vous faudra modifier la formule f avec les bons termes à considérer.
( sauf si toto, tata, titi sont corrects. )

 

[BENAM69]

Hello sylvanu

Je te remercie pour ton retour
Ta méthode marche aussi bien.
C'est super
En effet, elle est plus rapide que celle que j'ai c'est top !!!

Belle journée à toi

BeNam69