Performance macros sous excel 2016

Bonjour
Ta réflexion est incomplète.
Si, avec ce code, tu commences par le début, tu te feras inévitablement des croche-pieds avec la numérotation des lignes !
Imagine que tu supprimes la ligne 2 -->> la 3ème deviendra ipso-facto la 2ème et ta boucle perdra donc son efficacité.
On ne peut faire cela qu'à la condition :
- de créer une plage (par Application.Union) de toutes les lignes à supprimer
- de supprimer d'un seul coup, in fine, les rangs entiers de cette plage. Mais ce serait alors un code totalement distinct.

Bonjour,

Comme on ne pourras pas changer la logique de VBA sur Excel, dans ce cas là autant changer la méthode de suppression de ligne, ce que je proposais en vba et expliquais aussi par Marc puis moi à faire manuellement prenant moins de 2 minutes

PS : mettre le code entre balise avec la touche # pour la lisibilité de celui-ci - cf lien dans ma signature
Dans le code donner en lien peu de chose à changer (Bien sur pour comprendre le code, utiliser le pas à pas avec la fenêtre des variables locales pour voir à quoi correspond les variables et l'aide VBA))

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20

Sub Demo() Dim DL As Long, Col As Integer, V DL = Cells(Rows.Count, 1).End(xlUp).Row 'Dernière ligne remplie Col = Cells(1).CurrentRegion.Columns.Count + 1 ' Numéro de la colonne après la dernière colonne utilisé Application.ScreenUpdating = False With Range(Cells(1, Col), Cells(DL, Col)) .FormulaLocal = "=SI($A1 = ""X"";1;0)" 'on applique la formule sur la colonne supplémentaire .Value = .Value End With With Cells(1).CurrentRegion .Sort Columns(Col), xlAscending, Header:=xlNo 'on trie dans l'ordre croissant les données via la colonne supplémentaire ou l'on a mis la formule V = Application.Match(1, .Columns(Col), 0) 'on repère ou se trouve le 1er "1" dans la colonne supp If Not IsError(V) Then Rows(V & ":" & .Rows.Count).EntireRow.Clear 'on efface l'ensemble des lignes dont la valeur est 1 dans la colonne supp. précédemment triée End If .Columns(Col).Clear 'on efface la colonne supplémentaire End With Application.ScreenUpdating = True ' PS : et tout cela peut se faire manuellement comme expliqué dans les posts ci-dessus End Sub

---

Edit : Corr. d'orthographe

Bonjour,
Vba ne fait pas les chose à l'envers ! Ne dit on pas que la nature a horreurs du vide!

Quand un électron s'en va un autre prend sa place!

Telle est la raison de commencer par la fin pour notre ca si on veut parcourir tous les éléments!
Si je supprime la ligne 1 la ligne 2 prend sa place; après si je supprime la ligne 2 je supprime la ligne qui avant avait la position 3!

Citation:

---

Envoyé par unparia

...
On ne peut faire cela qu'à la condition :
- de créer une plage (par Application.Union) de toutes les lignes à supprimer
- de supprimer d'un seul coup, in fine, les rangs entiers de cette plage. Mais ce serait alors un code totalement distinct.

---

:plusser:
Ce qui lui a ete donn2 dans un exemple de code au post #38 en se passant de boucle. Il lui suffit de mettre la bonne valeur de colonne à la ligne n°2 de ce code.

Maintenant s'il veut vraiment pour une raison obscure, savoir comment faire une boucle de suppression de lignes dans le sens qu'il veut avec for, il doit juste s'armer en conséquence avec une variable compteur qui s'incrémente dans la condition à l'intérieur de la boucle For i (IF condition -> supprimer ligne c - ELSE c +1). Ce qui n'a pas d'intérêt si la boucle For vise juste à supprimer des lignes, autrement pour passer outre les limitations de For se tourner vers Do ... Loop [ Until | Wend | <,>,<=,>= ]

Je ré-ouvre cette discussion après avoir lu le document "Formation Excel- VBA débutant" (EXCELLENT ! écrit par l'un de vous je crois)
A l'époque je n'avais rien compris à ce document, maintenant il m'éclaire parfaitement

J'ai été attiré par l'article en bas de la page 179
Pièce jointe 401711

Je tente de voir comment améliorer une macro qui supprime les lignes ayant en "X" en colonne 40 pour finaliser une mise en page, voici le code qui tourne parfaitement mais assez long (j'ai plusieurs macros qui font ce type de mise en page)

Code:

---

1 2 3 4 5 6 7 8 9

For i = derligPdf To 1 Step -1 If Cells(i, 40).Value = "X" Then For Each shap In ActiveSheet.Shapes If shap.TopLeftCell.Row = i Then shap.Delete Next Cells(i, 40).EntireRow.Delete End If Next i

---

Dans un premier temps si quelqu'un peut me dire si le code du cours (incompréhensible pour moi pour le moment) peut être adapté pour remplacer ma macro.

le faire sera une autre histoire

Citation:

---

Envoyé par retraite83

Je tente de voir comment améliorer une macro qui supprime les lignes ayant en "X" en colonne 40 pour finaliser une mise en page, voici le code qui tourne parfaitement mais assez long (j'ai plusieurs macros qui font ce type de mise en page)

Dans un premier temps si quelqu'un peut me dire si le code du cours (incompréhensible pour moi pour le moment) peut être adapté pour remplacer ma macro.

---

Tu cherches a supprimer des choses (lignes + shape) alors que la macro de ton cours sert a faire un copier coller (c'est écrit dans le texte), donc non je pense que tu ne regardes pas au bon endroit.

Code:

---

1 2 3 4 5 6 7 8 9

For i = derligPdf To 1 Step -1 If Cells(i, 40).Value = "X" Then For Each shap In ActiveSheet.Shapes If shap.TopLeftCell.Row = i Then shap.Delete Next Cells(i, 40).EntireRow.Delete End If Next i

---

Ce qui est long, c'est que pour chaque ligne X tu boucles sur toutes les shapes
Voici ce que je ferais, une seule boucle sur les shapes

Code:

---

1 2 3

For Each shap In ActiveSheet.Shapes If cells(shap.TopLeftCell.Row,40).value = "X" Then shap.Delete Next

---

Puis un filtre sur la colonne 40 avec la valeur X pour supprimer toutes les lignes d'un coup

merci je vais voir cela,

qu'entends tu par un filtre sur la colonne 40?

Citation:

---

qu'entends tu par un filtre sur la colonne 40?

---

Pour le filtre, voir l'aide: https://support.office.com/fr-fr/art...6-38c37dcc180e
Pour la colonne 40, c'est dans ton code If Cells(i, 40).Value = "X" ThenUne fois les données filtrées tu peux faire la suppression sans boucle, ce qui est bien plus rapide (un des membres du forum a mis un tuto la dessus dans la sous-section contribuez: https://www.developpez.net/forums/d1...on-lignes-vba/)

pour tester j'ai fait cela après avoir mis en un titre sur la ligne 1 de la colonne 40 :

Code:

---

1 2 3 4 5 6 7 8

For Each shap In ActiveSheet.Shapes If Cells(shap.TopLeftCell.Row, 40).Value = "X" Then shap.Delete Next   Range("AN1:AN1365").AutoFilter Field:=1, Criteria1:="X" Rows("2:1365").Delete Range("AN1:AN1365").AutoFilter Field:=1

---

1365 sera une variable mais j'ai mis en valeur absolue pour le test

J'ai le message en boucle "les cellules fusionnées ne le seront plus" sur la ligne

Code:

---

Rows("2:1365").Delete

---

Bonjour,
Si ta feuille Excel ne dispose pas de formules tu peux utiliser un filtre élaboré.

Il collera tous ce que tu veux garder dans un autre onglet. Il ne te restera qu'à remplacer l'existant par le nouveau.

C'est quasi instantané.

Il y a beaucoup de formule dans cette feuille (mise en page pour être éditée)

J'ai fait un test sur un autre cas sans image

Code:

---

1 2 3 4

Range("AO:AO2685").AutoFilter Field:=1, Criteria1:="X" Rows("2:2685").Delete Range("AO1:AO2685").AutoFilter Field:=1

---

Cela marche très bien, IMPRESSIONNANT 4 secondes au lieu d'une minute sur les 2685 lignes

par contre avec les images

Code:

---

1 2 3 4 5 6 7 8 9

For Each shap In ActiveSheet.Shapes If Cells(shap.TopLeftCell.Row, 40).Value = "X" Then shap.Delete Next   Range("AN1:AN1365").AutoFilter Field:=1, Criteria1:="X" Rows("2:1365").Delete Range("AN1:AN1365").AutoFilter Field:=1

---

Cela ne marche pas, toujours boucle sur le message disant que les cellules fusionnées ne le seront plus… En allant au bout il y a un décalage dans le résultat final dans la mise en page

Je reprendrai mes tests après mes vacances (je pars demain, je ne vais pas prendre de risque la veille…)

Merci

Bonjour,

Si tu aimes les tests et que tes shapes sont liées à tes cellules.
Regarde ce post : https://www.developpez.net/forums/d1...a/#post9636196

À adapter bien sûr.

re
bonjour
le probleme de lenteur avec une boucle c'est justement que tu declanche forcement le calculate meme a l'envers

si j'ai bien compris
tu veux suprimer toutes les shapes si elles ont la cellules (shap.topleftcell.row,40)avec un "X" et tu veux par la meme occasion supprimer la ligne

seulement a chaque suppression les emplacement shape changent forcement deja on a un hic ici sans parler du calculate qui va se repeter autant de fois que de lignes supprimées


je te propose de boucler mais de rien supprimer
ca y est le toulonnais il a craqué !!!:mouarf:
nan!!nan!!

on va tout simplement dans une boucle sur les shapes créer un groupe de shapes que l'on appelera "toto" ET!!!!! par la meme occasion créer un range avec union
voila en sortie de boucle tu a ta plage de cellules a supprimer ainsi que toute les shapes a supprimer aussi
une derniere chose a faire c'est de replacer les shapes restantes a leur place car elles ont forcement été decalées

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17

Sub test() Dim i&, tabloshap(), rng As Range For Each shap In ActiveSheet.Shapes If ActiveSheet.Cells(shap.TopLeftCell.Row, 40).Value = "X" Then i = i + 1: ReDim Preserve tabloshap(1 To i): tabloshap(i) = shap.Name If rng Is Nothing Then Set rng = shap.TopLeftCell Else Set rng = Union(rng, shap.TopLeftCell) End If Next ActiveSheet.Shapes.Range(tabloshap).Group.Name = "toto" ActiveSheet.Shapes("toto").Delete rng.EntireRow.Delete 'IMPORTANT!!!!! ' on remet a leur place les shapes restantes qui ont forcement été decalées For Each shap In ActiveSheet.Shapes shap.Top = shap.Top + shap.TopLeftCell.Height Next End Sub

---

voila tu suprimes tes shapes et cellules en une seule fois
;)

Salut.

Mon grain de sel…

Avant de vouloir faire du tout en un avec un code non maîtrisé par le demandeur (et éviter ainsi une laborieuse adaptation à son cas), il serait peut-être déjà judicieux d'inhiber le calcul et le rafraîchissement d'écran avant la suppression.

Code:

---

1 2 3 4 5 6 7 8 9 10

Dim CalculationMode As XlCalculation   CalculationMode = Application.Calculation Application.ScreenUpdating = False   ' Ici, la boucle de suppression   Application.Calculation = CalculationMode application.ScreenUpdating=true

---

Idéalement, on encadre cela dans une gestion d'erreur

Bonjour
oui Pierre aussi
je me suis seulement attaqué a demultiplier les supressions a les ramener donc a une seule suppression (shapes/cells)
rien empleche effectivement les screenupdating=false les calculate a false et tout le toin toin

une version un peu plus precise +gestion de la non occurence dans un if

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

Sub test() Dim i&, a&, tabloshap(), tabshapesauvée(), rng As Range, calculateMode Application.ScreenUpdating = False calculateMode = Application.Calculation Application.Calculation = xlCalculationManual For Each shap In ActiveSheet.Shapes If ActiveSheet.Cells(shap.TopLeftCell.Row, 7).Value = "X" Then i = i + 1: ReDim Preserve tabloshap(1 To i): tabloshap(i) = shap.Name If rng Is Nothing Then Set rng = shap.TopLeftCell Else Set rng = Union(rng, shap.TopLeftCell) Else a = a + 1: ReDim Preserve tabshapesauvée(1 To a): tabshapesauvée(a) = shap.Name & ":" & shap.Top End If Next If UBound(tabloshap) > 0 Then ActiveSheet.Shapes.Range(tabloshap).Group.Name = "toto" ActiveSheet.Shapes("toto").Delete rng.EntireRow.Delete '************************************************************************************************ 'IMPORTANT!!!!! si LA correspondence shape/ligne n'est pas a prendre en compte dans le contexte ' on remet a leur place les shapes restantes qui ont forcement été decalées For i = 1 To UBound(tabshapesauvée) ActiveSheet.Shapes(Split(tabshapesauvée(i), ":")(0)).Top = Split(tabshapesauvée(i), ":")(1) Next '************************************************************************************************* End If Application.Calculation = calculateMode End Sub

---

merci à tous,
je regarderai cela tranquillement à mon retour de vacances, bon mois d'aout à tous