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

BENAM69

XLDnaute Occasionnel
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 :
VB:
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
VB:
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
 

Pièces jointes

  • Test SDR.xlsm
    628.8 KB · Affichages: 0

BENAM69

XLDnaute Occasionnel
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
 
Dernière édition:

BENAM69

XLDnaute Occasionnel
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 :

VB:
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

XLDnaute Barbatruc
Supporter XLD
Bonjour Benam, Scraper,
Une autre approche en PJ, qui s'est révélée à de multiples reprises la solution la plus rapide, avec :
VB:
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. 😂😂😂 )
 

Pièces jointes

  • Test SDR.xlsm
    911.7 KB · Affichages: 0

Discussions similaires

Réponses
6
Affichages
421

Statistiques des forums

Discussions
313 283
Messages
2 096 810
Membres
106 751
dernier inscrit
Souleymani