copie/supression de shapes bug

Version imprimable

Bonjour,

j'ai réalisé une macro dont l'objectif est de copier une plage de cellule comprenant des cellules de calculs, des images et des listes déroulantes, d'une feuille vers une autre feuille.
La plage de cellule en question possède des listes déroulantes (données> validation>liste). la copie se passe bien lorsque je n'utilise pas une des listes déroulantes. Lorsque que je modifie le texte d'une cellule en choisissant un autre élément de la liste, et que je lance ma macro de copie vers l'autre feuille là ca bug à ce niveau du code (en rouge) :
Code:

1 2 3 4 5 6 7 8 9 10 Set plagerech = Sheets(FICHE_CALCUL).Range(cimage & ld_module & ":" & cimage & lf_module) For Each obj In ActiveSheet.Shapes Worksheets(FICHE_CALCUL).Activate Set plageimg = Range(obj.TopLeftCell.Address) If Not Intersect(plageimg, plagerech) Is Nothing Then 'Verifie si le shape est dans la plage de cellules cible obj.Copy Sheets("PRESENTATION").Range(cimage_pres & ld_pres).PasteSpecial End If Next obj
Il n'arrive pas a copier le shape qui ne semble plus reconnu.

Si par contre j'enregistre mon fichier excel, et que je lance la macro là ca marche bien...

je vous avoue que je ne comprend pas pourquoi... en quoi l'enregistrement joue t il sur la reconnaissance des shape, en quoi la modification d'un élément d'une liste de selection peut provoquer un probleme dans la copie ou supression d'un shape ?

Merci pour votre aide !

Bonjour et bienvenue sur le forum,

Ci-dessous une solution éventuelle.

Les objets seront copiés seulement si ceux-ci sont complètement intégrés dans la plage de cellules sélectionnée et sont repositionnés exactement au même endroit sur la feuille 2

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
28
29
30
31
32
33
34
Sub Copie_Object()
Application.ScreenUpdating = False
Dim plage As Range, Shp As Shape
Dim Lshp As Single, Tshp As Single, Wshp As Single, Hshp As Single, Xshp As Single, Yshp As Single
Dim Lp As Single, Tp As Single, Wp As Single, Hp As Single, Xp As Single, Yp As Single
 
Set plage = Selection
Lp = plage.Left
Tp = plage.Top
Wp = plage.Width
Hp = plage.Height
Xp = Lp + Wp
Yp = Tp + Hp
 
For Each Shp In ActiveSheet.Shapes
    Lshp = Shp.Left
    Tshp = Shp.Top
    Wshp = Shp.Width
    Hshp = Shp.Height
    Xshp = Lshp + Wshp
    Yshp = Tshp + Hshp
    If Tshp >= Tp And Lshp >= Lp And Xshp <= Xp And Yshp <= Yp Then
        Shp.Copy
        With Sheets(2)
            .Paste
            .Shapes(.Shapes.Count).Name = Shp.Name
            .Shapes(Shp.Name).Left = Lshp
            .Shapes(Shp.Name).Top = Tshp
        End With
    End If
Next
 
Application.ScreenUpdating = True
End Sub

27/06/2008, 11h05
cam_cam

Merci bien !
Comme ca ca fonctionne très bien.