ModifierWhileWendParForEach

[Moa]

Salut à tous les VBtistes !

Suite à un post de Dominique du 25/07, concernant la vitesse d'exécution d'une macro, j'ai décidé de modifier une de mes macros.

(Je sais @+Thierry, que j'ai déjà posé la question, à la suite de ce même post, mais vu qu'il se trouve 4 pages en arrière, je doute que quelqu'un ne le lise).

Donc voici ma macro :

Sub DeleteUn()
Sheets("Feuil1").Select

Application.Calculation = xlManual

Sheets("Feuil1").Activate
i = 1
While Range("A3").Offset(i).Value <> ""
If Range("A3").Offset(i).Value = 1 Then
Range("A3").Offset(i).EntireRow.Select
Selection.Delete shift:=xlUp
i = i - 1
End If
i = i + 1
Wend
Application.Calculation = xlCalculationAutomatic

End Sub

Comme @+Thierry et Ti, vous préconisiez de supprimer les "Select", j'ai modofié :

Range("A3").Offset(i).EntireRow.Select
Selection.Delete shift:=xlUp

Par : Range("A3").Offset(i).EntireRow.Delete

Et ça marche

Mais j'ai cherché à changer While...Wend par For...Each, et là, je galère.

Et voilà ma nouvelle macro :

Sub TestDeleteUn()
Dim Cellule As Range
For Each Cellule In Range("A:A")
If Cellule.Value = 1 Then
Cellule.EntireRow.Delete
End If
Next Cellule
End Sub

J'ai omis le départ à la cellule 3, volontairement.

Et là j'ai un hic...

La macro fonctionne bien, mais je dois la lancer trois ou quatre fois, pour qu'elle delete toutes les lignes dont la colonne "A" est remplie par un "1".

Et mon deuxième problème, est d'arriver à faire commencer cette macro qu'à partir de la ligne 3.

Donc, si un Vbtiste charitable, pris de pitié par ma modeste connaissance, voulait bien m'aiguiller un Gros pNeu, ce serait vraiment très très sympa.

Merci d'avance à vous tous !

@ +

Moa

 

[LaurentTBT]

Salut Moa.

Par hasard, est-ce que si tu as deux 1 qui se suivent, tu ne garderais pas le deuxième (en fait, quand tu delete, on saute la ligne suivante). essaye de faire ta macro pas à pas, tu comprendras mieux que mes expications!

Bon, j'ai l'explication, mais pour la solution, pour le moment je ne vois pas trop.

@+. Laurent.

 

[LaurentTBT]

Encore moi.

Je confirme la cause du problèmre d'ailleur dans ta première version, tu le prenais en compte dans ta boucle While...Wend, puisque tu avais un i=i-1.
Maintenant, on ne peut plus modifiera cellule du for each ...
J'ai essayer de faire revenir à la cellule précédente après avoir deleté une ligne, mais cela est refusé! Je ne pense pas qu'il y ait de solution. Peut-être me ferra-t-on mentir.

Sinon, pour ta deuxième question, début à la ligne 3, tu aurais pu mettre tout simplement For Each Cellule In Range("A3:A65536").

Sur ce, j ne me vois pas trouver de solution pour le moment, donc bonne nuit.

 

[LaurentTBT]

En fait, j'ai trouvé une solution, en partant de la cellule 2 pour analyser la cellule suivante. Donc si je delete la ligne qui suit la cellule en cours, cela ne perturbera pas la boucle.
Voilà ce que ça donne:
Sub TestDeleteUn()
Dim cellule As Range
For Each cellule In Range("A2:A65536")
Do Until cellule.Cells(2, 1) <> 1
cellule.Cells(2, 1).EntireRow.Delete
Loop
Next cellule
End Sub

Je suis obligé d'insérer une autre boucle, car si je me contente de supprimer le 1 qui suit, et que je passe alors à la cellule suivante qui peut être aussi un 1, alors j'analyse celle qui est encore en dessous, et je garde le 1 du milieu.

Du coup, je ne sait pas si ça vaut le coup, et si la procédure ainsi est plus rapide. A toi de voir. Mais c'était un bon exercice pour moi.

Cette fois au moins, je pense pouvoir dormir tranquile.

@ demain. Laurent.

 

[Moa]

Salut LaurentTBT !

Je vois que comme moi, tu es encore dessus.

Je viens de faire plein de tests et de recherche, et je ne fais que gagner quelques secondes, mais pour l'instant rien de bien formidable.

Donc voici ma vrai macro :

Sub DeleteFaux()

Sheets("Feuil1").Select

Application.Calculation = xlManual

Sheets("Feuil1").Activate

i = 1
While Range("A15").Offset(i).Value <> ""
If Range("A15").Offset(i).Value = False Then
Range("A15").Offset(i).EntireRow.Select
Selection.Delete shift:=xlUp
i = i - 1
End If
i = i + 1
Wend

Application.Calculation = xlCalculationAutomatic

End Sub

Pour deleter 208 lignes sur une base de 2580 lignes, Temps mis 26" 21.

En changeant :

Range("A15").Offset(i).EntireRow.Select
Selection.Delete shift:=xlUp

Par : Range("A15").Offset(i).EntireRow.Delete , Temps mis 25" 42

En rajoutant : Application.ScreenUpdating = Fasle, Temps mis 24" 31

En rajoutant : Application.EnableEvents = False, Temps mis 24" 28

En enlevant : Sheets("Feuil1").Select

Sheets("Feuil1").Activate, Temps mis 24" 18

Je vais donc essayer, dès maintenant ta macro, mon cher Laurent.

Et je reviens t'en parler.

@ +

Moa















Sub DeleteFaux()
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual

i = 1
While Range("A15").Offset(i).Value <> ""
If Range("A15").Offset(i).Value = False Then
Range("A15").Offset(i).EntireRow.Delete
i = i - 1
End If
i = i + 1
Wend
Application.EnableEvents = True
Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

End Sub

 

[Moa]

Re !

Voilà une nouvelle macro encore plus LENTE....décidément :

Sub DeleteFaux()
Dim CelluleCourante As Range
Dim CelluleSuivante As Range
Set CelluleCourante = ActiveSheet.Range("A16")
Do While Not IsEmpty(CelluleCourante) = True
Set CelluleSuivante = CelluleCourante.Offset(1, 0)
If CelluleCourante.Value = False Then
CelluleCourante.EntireRow.Delete
End If
Set CelluleCourante = CelluleSuivante
Loop

End Sub

Soit maintenant : 39,046 secondes

Et avec :

With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = False
.ScreenUpdating = False
End With

36,54 secondes.

Et avec la nouvelle macro 1 seconde :

Sub RecopieVrai()

Sheets("Filtrage").Select
Range("A16:O16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

Sheets("VersExport").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Sheets("Filtrage").Select
Range("c16:O16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select

Sheets("VersExport").Select
Range("A2").Select
Selection.AutoFilter Field:=1, Criteria1:="1"
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select

Selection.Copy

Sheets("Filtrage").Select
Range("A16").Select
ActiveSheet.Paste


Sheets("VersExport").Select
Selection.AutoFilter Field:=1
Selection.AutoFilter
Range("A3").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Range("A1").Select

End Sub

En fait que fait cette nouvelle macro :

Elle sélectionne les lignes et colonnes à garder dans la feuille de départ (Filtrage), elle les copie, puis va faire un Coller spécial Valeur, dans une autre feuille (export).

Elle revient dans la feuille de départ faire le néttoyage.

Puis elle repart dans la feuille Export, applique un filtre automatique, mais pour garder les "Vrais".

Elle sélectionne les "Vrais" restants et les copie.

Elle repart dans ma première feuille et recolle les lignes à garder.

Puis elle va faire le ménage dans ma feuille Export.

Et voilà !

Plein de manips faites avec l'enregistreur de macro, puis légèrement modifiées après.

Macro testée pour effacer 1500 lignes sur 15 000 en 1,5 seconde.

Par contre sur une dizaine de tests, sur des gros fichiers, la macro a planté une fois....????

Mais, honnêtement, je préfèrerais une macro plus "Vba", qui me semblerait plus sure dans le temps.

@ +


Moa

@ +

Moa

 

[LaurentTBT]

Bonjour Moa.

Juste pour info, que donnait ma macro avec la boucle For each cellule...?

Sinon, pour ta dernière version qui, si j'ai bien compris, est de loin la plus rapide, tu peux peut-être peaufiner en enlevant tous les select:

Par exemple, au lieu de :
Sheets("Filtrage").Select
Range("A16:O16").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy

si il n'y a pas de données au delà de la colonne O, on peut utiliser la fonction atteindre en cherchant la plage en cours:
Cela donnerait tout simplement:
Sheets("Filtrage").range("A16").currentregion.copy
NB: cela ne fonctionne que si tu n'as pas de trou dans tes données (une ligne ou une colonne vide )
Voici ce que cela donnerait au final:

Sub RecopieVrai()

Sheets("Filtrage").Range("A16").CurrentRegion.Copy

Sheets("VersExport").Range("A3").PasteSpecial Paste:=xlValues

Sheets("Filtrage").Range("A16").CurrentRegion.Columns("C:O").ClearContents

Sheets("VersExport").Range("A2").AutoFilter Field:=1, Criteria1:="1"
Sheets("VersExport").Range("A3").CurrentRegion.Copy

Sheets("Filtrage").Range("A16").PasteSpecial Paste:=xlValues

Sheets("VersExport").Range("A2").AutoFilter
Sheets("VersExport").Range("A3").CurrentRegion.ClearContents

End Sub

Il y a sinon peut-être moyen de travailler avec SpecialCells(xlCellTypeLastCell) pour éviter de chercher et la dernière ligne et la dernière colonne.

Ce ne sont que quelques pistes.

Bon courage et bonne journée. Laurent.