Discussion :

[unparia]

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.

[RyuAutodidacte]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Invité]

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!

[NVCfrm]

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

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 | <,>,<=,>= ]

[retraite83]

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


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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[halaster08]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[retraite83]

merci je vais voir cela,

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

[halaster08]

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/)

[retraite83]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

Rows("2:1365").Delete

[Invité]

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

[retraite83]

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

[retraite83]

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

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[RyuAutodidacte]

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.

[patricktoulon]

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é !!!
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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[Pierre Fauconnier]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[patricktoulon]

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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

[retraite83]

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