BUG: Manipuler des SHAPES

Question

Dans la Feuil3 (codename = base) j'ai un range fusionné dans lequel je dessine des shapes (formes). En cliquant sur le bouton, j'aimerai copier ces shapes au MEME ENDROIT dans les Feuil5(dest) et Feuil6(dest1). J'ai déjà fait la macro, mais j'ai 2 problèmes: -Ma fonction delete_shape bug et je n'arrive donc pas à effacer les shapes présentes des Feuil5(dest) et Feuil6(dest1); -Quand la macro copie les shapes sur les Feuil5(dest) et Feuil6(dest1), elle ne le fait pas exactement au même endroit dans le range, et là je ne comprend pas pourquoi! Merci par avance pour votre aide...

SylChat · Answer

Avec ça, ça marche de mon côté Sub selectshape() 'on efface des shape présentes delete_shape dest.Name delete_shape dest1.Name 'on copie les nouvelles shape de feuil3(base) sur feuil5(dest) et Feuil6(dest1) For Each S In ActiveSheet.Shapes If S.Name Like "Rectangle*" Then S.Select base.Shapes(S.Name).Copy dest.Select dest.Paste dest.Range("$B$5:$F$20") End If Next S End Sub Sub delete_shape(Arg1 As String) For Each S In ThisWorkbook.Sheets(Arg1).Shapes If Not Intersect(S.TopLeftCell, Range("$B$5:$F$20")) Is Nothing Then S.Select False Selection.Delete End If Next S End Sub A te relire...

SylChat · Answer

Je viens de restester le code que je t'ai fourni hier, et je n'ai ni bug, ni soucis de copie. Pour la suppression du shapes dont tu me parles à tu bien changé le paramètre de la sub ? Arg1 As String Je veux bien que tu mettre en lien ton fichier pour voir les modif apportées s'il te plait...

SylChat · Answer

J'ai une interrogation.

Pourquoi faire un intersect sur des cellules fusionnées?

du coup j'ai modifié cela

    Sub selectshape()

    'on efface des shape présentes
    delete_shape dest.Name
    delete_shape dest1.Name

    'on copie les nouvelles shape de feuil3(base) sur feuil5(dest) et Feuil6(dest1)
    base.Activate
    For Each S In ActiveSheet.Shapes
        If S.Name Like "Rectangle*" Then
            S.Select
             base.Shapes(S.Name).Copy
             'dest.Select
             dest.Paste dest.Range("$B$5:$F$20")
             dest1.Paste dest1.Range("$B$5:$F$20")
        End If
    Next S
    End Sub

    Sub delete_shape(Arg1 As String)
    ThisWorkbook.Sheets(Arg1).Activate
    For Each S In ThisWorkbook.Sheets(Arg1).Shapes
    'BUG ICI

        S.Select False
        Selection.Delete
    Next S

    End Sub

bon ça marche chez moi mais....

Hulk · Answer

A tester, mais pour la position... Comme le dit SylChat mieux vaut ne pas utiliser des cellules fusionnées. Sub selectshape() 'Déclare les variables Dim ws As Worksheet Dim s As Shape On Error Resume Next 'Boucle sur toutes les feuilles For Each ws In Worksheets 'Boucle sur tous les shapes de toutes les feuilles For Each s In ws.Shapes 'Si la feuille se nomme autrement que "Feuil3" alors If ws.Name &lt;&gt; "Feuil3" Then 'Efface le shapes s.Delete 'Fin de la condition End If If Not Intersect(s.TopLeftCell, Range("$B$5:$F$20")) Is Nothing Then s.Select End If Next s Selection.Copy 'Si la feuille ne se nomme pas "Feuil3" alors copie '//si pas cette condition, il copie aussi le shapes dans la Feuil3\ If ws.Name &lt;&gt; "Feuil3" Then base.Paste ws.Range("$B$5:$F$20") End If Next ws End Sub...

SylChat · Answer

Tu pourras stocker les nom des feuilles que tu veux traiter dans un array et boucler sur cet array...

Hulk · Answer

Re,

Voici le code modifié avec la même position des formes que la forme copiée.

Il y a toujours des boucles (2) qui bouclent sur toutes les feuilles, mais pas pour la copie, ça tu choisis toi qu'elle(s) feuille(s) copier.

J'ai pas essayé avec un Array sur les feuilles comme le suggère SylChat, mais c'est une bonne solution ou un tableau.

Sub selectshape()

    Dim ws As Worksheet
    Dim s As Shape

    For Each ws In Worksheets
        For Each s In ws.Shapes
            If ws.Name <> "Feuil3" Then
                s.Delete
            End If
        Next s
    Next ws

    For Each s In ActiveSheet.Shapes
        If Not Intersect(s.TopLeftCell, Range("$B$5:$F$20")) Is Nothing Then
            s.Select
        End If
    Next s

    Selection.Copy

    'Ici tu colles dans les feuilles que tu veux
    base.Paste dest.Range("$B$5:$F$20")
    base.Paste dest1.Range("$B$5:$F$20")

    For Each ws In Worksheets
        For Each s In ws.Shapes
            If ws.Name <> "Feuil3" Then
                'La forme de Feuill3 se nomme "Rectangle 13" attention à ça si tu lui donnes un autre nom
                s.Top = ActiveSheet.Shapes("Rectangle 13").Top
                s.Left = ActiveSheet.Shapes("Rectangle 13").Left
            End If
        Next s
    Next ws

End Sub