conserver que les lignes contenant, en colonne "D", un critère et effacer les autres

  • Initiateur de la discussion Initiateur de la discussion Broch002
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

Broch002

XLDnaute Occasionnel
Bonjour,

Tout d'abord, merci de votre aide, ce forum est génial.
Voici mon problème, dans un classeur, j'ai une feuille qui peut contenir 50 000 lignes.
Dans la colonne "D", plusieurs noms différents sont répertoriés ex:
Toto
Baba
Lulu
JoJo
J'essaye, par une macro, de ne conserver que les lignes comportant le mot Jojo. et d'éliminer les autres. J'ai trouvé cette macro, qui démarre, mais qui ne s'arrète jamais.

Sub REFERENCES_JoJo()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlManual
Sheets("Références").Select
Dim z$, i&, k&
k = Cells(50000, 4).Row
For i = k To 2 Step -1
z = Cells(i, 4).Value
If Not (Cells(i, 4) Like ("Jojo")) Then Rows(i).Delete
Next
ActiveWorkbook.Save
Application.Calculation = xlAutomatic
End Sub

J'ai tenté de stopper dans la macro le calcul automatique et de le rétablir à la fin, mais cela ne change rien.

J'ai essayé une autre macro, en enregistrant avec l'outil Excel, cela fonctionne, à une vitesse extraordinaire: Macro enregistrée:

Sub Jojo()

ActiveSheet.Range("$A$1:$Q$50000").AutoFilter Field:=4, Criteria1:= _
"<>Jojo", Operator:=xlAnd
Range("A2204").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
ActiveSheet.Range("$A$1:$Q$2203").AutoFilter Field:=4
End Sub

Mais je pense que cela fonctionne avec le fichier d'aujourd'hui (A2204) mais demain si c'est (A5830) ???

Dans l'exemple joint, les noms sont triés ce n'est pas la cas dans mon exemple.

Avez-vous une solution ?

Merci d'avance.
 

Pièces jointes

Dernière édition:
Re : conserver que les lignes contenant, en colonne "D", un critère et effacer les a

bonjour Broch002🙂🙂
en passant par un tablo
on pourrait simplifier le code en connaissant le nombres de colonnes utilisées

le filtre est intéressant a utiliser aussi mais sur des tres grandes plages peut poser des pb...

Code:
Sub es()
Dim t(), t1(), x As Long, i As Long, y As Long, c As Long, r As Long
 c = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
 r = Cells.Find("*", , , , xlByRows, xlPrevious).Row
 t = Cells(2, 1).Resize(r, c).Value
 ReDim t1(1 To UBound(t), 1 To c)
 For i = 1 To UBound(t)
 If t(i, 4) = "Jojo" Then
 x = x + 1
 For y = 1 To c: t1(x, y) = t(i, y): Next y
 End If
 Next i
 Cells.ClearContents: [A2].Resize(x, c) = t1
 Erase t, t1
End Sub

ps attention a l'ecriture de jojo sensible a la case
autrement en debut module rajouter
Code:
Option Compare Text
 
Dernière édition:
Re : conserver que les lignes contenant, en colonne "D", un critère et effacer les a

Bonjour, Laetitia90.

Génial, la macro fonctionne impécable.
Par contre la ligne A1 c'est effacée, comment faire pour l'éviter, elle me sert pour les intitulés de colonne.
peut-il également y avoir plusieurs critères, par exemple "Jojo" et "lulu"
Merci pour la rapidité de la réponse.

Broch002
 
Dernière édition:
Re : conserver que les lignes contenant, en colonne "D", un critère et effacer les a

re,

Code:
Sub es()
Dim t(), t1(), x As Long, i As Long, y As Long
 t = Range("a2:m" & Cells(Rows.Count, 1).End(xlUp).Row)
 ReDim t1(1 To UBound(t), 1 To 13)
 For i = 1 To UBound(t)
 If t(i, 4) = "Jojo" Or t(i, 4) = "lulu" Then
 x = x + 1
 For y = 1 To 13: t1(x, y) = t(i, y): Next y
 End If
 Next i
 Range("a2:m" & Cells.Find("*", , , , , xlPrevious).Row).ClearContents
 [A2].Resize(x, 13) = t1
 Erase t, t1
End Sub

ps :salut Robert 🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂🙂
 
Dernière édition:
Re : conserver que les lignes contenant, en colonne "D", un critère et effacer les a

Bonjour Broch, bonjour le forum,

En pièce jointe ton fichier modifié. Les données ne sont plus triées et ça marche sur l'onglet actif :

Code:
Sub Jojo()
With ActiveSheet
    .Range("A1").CurrentRegion.AutoFilter field:=4, Criteria1:="<>Jojo", Operator:=xlAnd
    .Rows(1).Hidden = True
    Application.DisplayAlerts = False
    .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Delete
    .Rows(1).Hidden = False
    .Range("A1").AutoFilter field:=4
    .Range("A1").Select
    Application.DisplayAlerts = True
End With
End Sub
Le fichier :

[Édition]
Bonjour Lætitia on s'est croisé..
 

Pièces jointes

Re : conserver que les lignes contenant, en colonne "D", un critère et effacer les a

Bonsoir, à tous deux.

la modification de Laëtitia fonctionne admirablement, je vais essayer celle de Robert, mieux vaut deux solutions plutôt qu'une.

Merci à tous les deux.

J'ai une autre question, dans la même feuille, une fois les critères éliminés, les lignes restantes sont des lignes correspondant à des références, je les trie de manière à les classer puis je fais des sous-totaux à la référence.
Je ne garde que les sous-totaux pour pouvoir les exploiter. Bien sûr j'enregistre la macro avec l'outil excel, mais la macro, sur de gros fichiers, est lourde et longue. voici le code:

Sub Trie_Référence()

ActiveWorkbook.Worksheets("Références").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Références").AutoFilter.Sort.SortFields.Add Key:= _
Range("H1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Références").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1:M1").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Subtotal GroupBy:=8, Function:=xlSum, TotalList:=Array(10, 11, 12 _
), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Cells.Select
Range("A157").Activate
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveWindow.ScrollRow = 160
ActiveWindow.ScrollRow = 125
ActiveWindow.ScrollRow = 36
ActiveWindow.ScrollRow = 1
ActiveSheet.Range("$A$1:$M$217").AutoFilter Field:=8, Criteria1:= _
"<>*total*", Operator:=xlAnd
Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.EntireRow.Delete
ActiveSheet.Range("$A$1:$M$31").AutoFilter Field:=8
End Sub

Si vous pouvez vous pencher sur ce problème se serait super sympa, y a-il une autre solution?

Merci pour votre aide, vous m'avez simplifié la tache.

bonne Soirée.

Broch002


🙄
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour