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

[Broch002]

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.

 

[laetitia90]

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

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

Option Compare Text

 

[Broch002]

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

 

[laetitia90]

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

re ,tu as combien de colonnes utilisée pour simplifier ??

 

[Broch002]

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

Il y a 13 colonnes dans le fichier utilisé.

Broch002

 

[laetitia90]

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

re,

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

 

[Robert]

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 :

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é..

 

[Broch002]

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