Optimisation suppression de lignes contenant des images

**retraite83** · 25/08/2018, 14h32

Bonjour,

j'ai une macro qui marche parfaitement bien mais assez longue à l'exécution

Code :

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

1
2
3
4
5
6
7
8
9
10
11
 
' Suppression des lignes inutiles 
With Cells(Rows.Count, "AN").End(xlUp).MergeArea: derligPdf = .Cells(.Cells.Count).Row: End With    ' dernière ligne à supprimer
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

derligPdf est > 1000

Il me semble à l'étude de cette boucle qu'elle n'est pas optimum car en mode pas à pas je vois que :

Code :

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

1
2
3
For Each shap In ActiveSheet.Shapes
    If shap.TopLeftCell.Row = i Then shap.Delete
    Next

s'exécute ne nombreuses fois alors que je n'ai qu'une image par ligne, la boucle en jaune se fait sur :

Code :

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

1
2
If shap.TopLeftCell.Row = i Then
    Next

Je ne saisi pas le sens de cette boucle

Invité · 25/08/2018, 18h04

Envoyé par retraite83

Bonjour,

Quand tu insères une image au niveau de ta cellule dans un shape, tu n'as pas moyen de coller le nom du Shape dans la cellule pour associer directement le nom de la forme à la ligne ?

**retraite83** · 25/08/2018, 18h50

je ne vois pas comment, mes images sont insérées par Excel par les fonctions:

INDIRECT(RECHERCHEV(…..)

En fait je veux supprimer les lignes et image avec un "X" en colonne AN, dans les macros sans suppression d'image, pour optimise mon #1 je fais (sur les conseils d'un expert du forum):

Code :

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

1
2
3
4
 
Range("AN1:AN1365").AutoFilter Field:=1, Criteria1:="X"
Rows("2:1365").Delete
Range("AN1:AN1365").AutoFilter Field:=1

cela marche parfaitrement et très rapidement
Mais cela ne marche pas avec une image sur la ligne :

Code :

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

1
2
3
4
5
6
7
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

C'est pour cela que j'en suis revenu à mon #1 pour comprendre pourquoi c'est si long

Invité · 26/08/2018, 05h58

Envoyé par retraite83

je ne vois pas comment, mes images sont insérées par Excel par les fonctions:

C'est pas grave...

Une solution différente de celle de Patrick :

Le principe est de charger une matrice des shapes dont la ligne est à supprimer. Lorsque le cas se produit, on change le nom de la forme et on identifie la ligne.
On identifie la dernière ligne concernée par la destruction dans le tableau et je détruis séparément les formes, des lignes par une boucle.

La suppression étant limitée aux seules lignes sélectionnées, la méthode devrait être plus rapide que celle de ton premier message.

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
Option Explicit
 
Public MatriceShapes() As Variant
 
Sub DetruireLesShapes()
 
Dim I As Long, J As Long, DerniereLigne As Long
Dim ShImages As Worksheet
Dim ASupprimer As Boolean
 
    On Error GoTo Fin
 
    Set ShImages = Sheets("Feuil1")  ' A adapter
 
    ChargementMatriceShapes ShImages
 
    DerniereLigne = 0
    For I = LBound(MatriceShapes, 2) To UBound(MatriceShapes, 2)
        If MatriceShapes(1, I) > DerniereLigne Then DerniereLigne = MatriceShapes(1, I)
    Next I
 
 
    With ShImages
 
         For I = LBound(MatriceShapes, 2) To UBound(MatriceShapes, 2)
             .Shapes(MatriceShapes(0, I)).Delete
         Next I
 
         For J = DerniereLigne To 1 Step -1
             ASupprimer = True
             For I = LBound(MatriceShapes, 2) To UBound(MatriceShapes, 2)
                 If MatriceShapes(1, I) = J And ASupprimer = True Then
                    .Rows(MatriceShapes(1, I)).Delete
                    ASupprimer = False
                 End If
             Next I
         Next J
 
    End With
 
Fin:
 
    Set ShImages = Nothing
 
End Sub
 
 
 
Sub ChargementMatriceShapes(ByVal FeuilleImages As Worksheet)
 
Dim I As Long, J As Long, NbShapes As Long
 
    Erase MatriceShapes
 
    With FeuilleImages
 
         NbShapes = 0
         I = 0
         J = 1
         For NbShapes = .Shapes.Count To 1 Step -1
 
             If .Range("AN" & .Shapes(NbShapes).TopLeftCell.Row) = "X" Then
                 ReDim Preserve MatriceShapes(1, I)
                 .Shapes(NbShapes).Name = "ASupprimer" & J
                 MatriceShapes(0, I) = .Shapes(NbShapes).Name
                 MatriceShapes(1, I) = .Shapes(NbShapes).TopLeftCell.Row
                 I = I + 1
                 J = J + 1
             End If
         Next NbShapes
 
    End With
 
End Sub

**retraite83** · 26/08/2018, 09h17

je vais prendre le temps d'essayer les 2 solutions pour voir, en espérant n'avoir jamais à les modifier…

Pour revenir à mon premier message je ne comprends pas pourquoi en pas à pas je boucle à chaque i sur

Code :

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

1
2
3
4
 
For Each shap In ActiveSheet.Shapes
    If shap.TopLeftCell.Row = i Then shap.Delete
    Next

alors qu'il n'y a qu'une image par ligne
J'aurai eu tendance à écrire (dans le principe, sans parler de la syntaxe):

Code :

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

1
2
3
4
5
6
7
 
With Cells(Rows.Count, "AN").End(xlUp).MergeArea: derligPdf = .Cells(.Cells.Count).Row: End With    ' dernière ligne à supprimer
For i = derligPdf To 1 Step -1
If Cells(i, 40).Value = "X" Then
    shap.Delete
    Cells(i, 40).EntireRow.Delete
End If

Invité · 26/08/2018, 09h48

Envoyé par retraite83

Si les cellules sont fusionnées dans la colonne AN, utiliser ce code :

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
 
Option Explicit
 
Public MatriceShapes() As Variant
 
Sub DetruireLesShapes()
 
Dim I As Long, J As Long, DerniereLigne As Long
Dim ShImages As Worksheet
Dim ASupprimer As Boolean
 
    On Error GoTo Fin
 
    Set ShImages = Sheets("Images (2)")  ' A adapter
 
    ChargementMatriceShapes ShImages
 
    DerniereLigne = 0
    For I = LBound(MatriceShapes, 2) To UBound(MatriceShapes, 2)
        If MatriceShapes(1, I) > DerniereLigne Then DerniereLigne = MatriceShapes(1, I)
    Next I
 
 
    With ShImages
 
         For I = LBound(MatriceShapes, 2) To UBound(MatriceShapes, 2)
             .Shapes(MatriceShapes(0, I)).Delete
         Next I
 
         For J = DerniereLigne To 1 Step -1
             ASupprimer = True
             For I = LBound(MatriceShapes, 2) To UBound(MatriceShapes, 2)
                 If MatriceShapes(1, I) = J And ASupprimer = True Then
                    .Range("AN" & MatriceShapes(1, I)).MergeArea.EntireRow.Delete
                    ASupprimer = False
                 End If
             Next I
         Next J
 
    End With
 
Fin:
 
    Set ShImages = Nothing
 
End Sub
 
 
 
Sub ChargementMatriceShapes(ByVal FeuilleImages As Worksheet)
 
Dim I As Long, J As Long, NbShapes As Long
 
    Erase MatriceShapes
 
    With FeuilleImages
 
         NbShapes = 0
         I = 0
         J = 1
         For NbShapes = .Shapes.Count To 1 Step -1
 
             If .Range("AN" & .Shapes(NbShapes).TopLeftCell.Row) = "X" Then
                 ReDim Preserve MatriceShapes(1, I)
                 .Shapes(NbShapes).Name = "ASupprimer" & J
                 MatriceShapes(0, I) = .Shapes(NbShapes).Name
                 MatriceShapes(1, I) = .Shapes(NbShapes).TopLeftCell.Row
                 I = I + 1
                 J = J + 1
             End If
         Next NbShapes
 
    End With
 
End Sub

Invité · 26/08/2018, 09h51

Envoyé par retraite83

Pour revenir à mon premier message je ne comprends pas pourquoi en pas à pas je boucle à chaque i sur

Parce qu'il y a deux boucles imbriquées.

**patricktoulon** · 25/08/2018, 19h02

re
tu pourrais peut etre collectionner les lignes et les shapes et les supprimer toutes d'un coup

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
14
 
dim tablo(),x&,shap as shape,rang as range,mongroupe
With Cells(Rows.Count, "AN").End(xlUp).MergeArea: derligPdf = .Cells(.Cells.Count).Row: End With    ' dernière ligne à supprimer
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 x = x + 1: ReDim Preserve tablo(1 To x): tablo(x) = shap.Name
        Next
        If rang Is Nothing Then Set rang = Cells(i, 40) Else Set rang = Union(rang, Cells(i, 40))
    End If
    Set mongroupe = ActiveSheet.Shapes.Range(tablo).Group
    mongroupe.Delete
    rang.EntireRow.Delete
Next i

Optimisation suppression de lignes contenant des images [XL-2016]

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager