XL 2016 copier un objet sur toutes les feuilles

andrekn13 · 2 Octobre 2019

bonjour
je me suis usé à trouver le code, si une bonne âme connaît la démarche ....
ce code fonctionne pour un range mais pour un shapes c'est à chaque fois la misère ...;

Sub Macro9()
Dim Feuille As Worksheet
For Each Feuille In ThisWorkbook.Worksheets
'Feuille.Range("L10") = Sheets("FACT FROID").Range("L10") : CODE QUI FONCTIONNE
'Feuille.Range("L10") = Sheets("FACT FROID").Shapes.Range(Array("Left Arrow 19")) évidemment ça fonctionne pas ...

Sheets("FACT FROID").Shapes.Range(Array("Left Arrow 19")).Copy
Feuille.Range("L10").Paste
Next Feuille
End Sub

le problème est que le "copiage" se fait au hazard, et si l'on veut fixer sur une cellule, on perd la mémoire de la sélection .......
Merci de votre aide ...;

job75 · 2 Octobre 2019

Bonsoir à tous,

Si l'on veut éviter tout souci, en particulier quand on relance la macro, il faut compliquer un peu :

VB:

Sub Copier_Shape()
Dim ad$, F As Worksheet, s As Shape, flag As Boolean, w As Worksheet
ad = "$L$10" 'à adapter
Set F = ActiveSheet
Application.ScreenUpdating = False
For Each s In F.Shapes
    If s.TopLeftCell.Address = ad Then flag = True: s.Copy: Exit For
Next s
If Not flag Then Exit Sub
For Each w In Worksheets
    If w.Name <> F.Name Then
        For Each s In w.Shapes
            If s.TopLeftCell.Address = ad Then s.Delete
        Next s
        w.Visible = xlSheetVisible
        w.Activate
        w.Paste Destination:=w.Range(ad)
        ActiveCell.Activate
    End If
    F.Activate
Next w
End Sub

Les Shapes collées sont désélectionnées.

A+

andrekn13 · 2 Octobre 2019

job 75 , là , tu es passés à la vitesse grand V !!!
juste avant de faire une bétise, comme en fait mon classeur est très lourd et contient plusieurs shapes, le but est de juste en rajouter un sur tout le classeur :
Sheets("FACT FROID").Shapes("Left Arrow 24").Copy
est-ce à comprendre sur ton code que ad = "$L$10" 'à adapter est l'adresse où se trouve ce shapes ? pourtant j'ai compris qu'un shapes n'est pas lié à un range ? quand on sélectionne une cellule pour copier c'est "approximatif" ...….. la preuve est que si je copie cette cellule où il y a un shapes ça ne marche pas …..... non ?

andrekn13 · 2 Octobre 2019

essayé malgré tout, et à ma grande surprise ne fonctionne pas
j'ai pourtant le shapes sur la bonne cellule : ad = "$L$10"
en démarrant la macro sur le feuille où il y a le shapes à copier de partout

Roland_M · 3 Octobre 2019

re

si c'est pour le test d'éviter de recopier une deuxième fois alors:

Code:

Sub Copie4()
Dim Sh As Shape, TestPresent As Boolean
NomSh$ = "Rectangle 1" '<nom à adapter
'
Sheets(1).Shapes(NomSh$).Copy
For Each Feuille In ThisWorkbook.Worksheets
If Feuille.Name <> Sheets(1).Name Then
    TestPresent = False
    For Each Sh In Feuille.Shapes
     If Sh.Name = NomSh$ Then TestPresent = True: Exit For
    Next
    If Not TestPresent Then
       Feuille.Paste Destination:=Feuille.Cells(5, 5) ' à adapter
       Feuille.Activate: ActiveCell.Activate
    End If
End If
Next
End Sub

andrekn13 · 3 Octobre 2019

merci beaucoup je vais prendre le temps de comparer et comprendre pourquoi dans ton fichier ça marche et pas chez moi
pas encore compris mon bugg.
vu l'heure j'étais certain que tu n'aurais répondu que demain et j'en suis très agréablement surpris
je te remercie très profondément
dailleurs je remercie tous ceux qui ont contribué , donner de votre temps c'est toujours une grande leçon de modestie pour ceux qui en bénéficie

entre temps j'ai mixé ton code avec celui qui avait commencé pour comprendre comment mieux le vba

Sub Copier_Shape()
Dim ad$
ad = "$L$18"
Sheets("FACT FROID").Shapes("Left Arrow 24").Copy
For Each Feuille In ThisWorkbook.Worksheets
ActiveSheet.Range("L10").Select
If Feuille.Name <> Sheets(1).Name Then Feuille.Paste Destination:=Feuille.Range(ad)
Next Feuille
End Sub
Sub REVENIRPAGE1()
Sheets("Synthese").Select
'Sheets("Ann?e En Cours").Select

End Sub

et à mon grand étonnement ça marche nickel

il me reste donc à comprendre pourquoi ton fichier marche mais en le copiant sur mon fichier ça marche plus

pour infos, mon fichier contient env 400 onglets, et quand on veut revenir au 1er on passe " 2 heures" à faire défiler les onglets
1 fois ça va, mais aller et revenr régulièrement c'est pas pensable

grand merci à toute l'équipe

Roland_M · 3 Octobre 2019

re

pas très logique tout ça, rapport à l'exemple !?

d'une part ActiveSheet.Range("L10").Select < ne sert à rien !?
ça ne désélecte pas les shapes collées !?
et tu n'as plus le test qui évite de recopier autant de fois le même shape !?

l'exemple complet adapté selon tes données (ci-joint le classeur qui simule avec tes données)
REM: dans le code tu choisiras le test qui te convient ici:
' voir choix 1' ne pas copier dans la feuille source
'----------- 2' non plus dans la feuille FeuilPage1
'If Feuille.Name <> FeuilSource Then '1'
If Feuille.Name <> FeuilSource And Feuille.Name <> FeuilPage1 Then '2'

Code:

Sub Copie5()
Dim FeuilPage1$, NomShap$, FeuilSource$, AdresDestin$, Sh As Shape, TestPresent As Boolean
FeuilPage1$ = "Synthese" ' pour test et retour
NomShap = "Left Arrow 24" ' <
FeuilSource = "FACT FROID" ' <
AdresDestin = "$L$18" ' <
'
Sheets(FeuilSource).Shapes(NomShap).Copy
For Each Feuille In ThisWorkbook.Worksheets
' voir choix 1' ne pas copier dans la feuille source
'----------- 2' non plus dans la feuille FeuilPage1
'If Feuille.Name <> FeuilSource Then '1'
  If Feuille.Name <> FeuilSource And Feuille.Name <> FeuilPage1 Then '2'
    TestPresent = False
    For Each Sh In Feuille.Shapes
     If Sh.Name = NomShap Then TestPresent = True: Exit For
    Next
    If Not TestPresent Then
       Feuille.Paste Destination:=Feuille.Range(AdresDestin)
       Feuille.Activate: ActiveCell.Activate 'déselect shape
    End If
End If
Next
Sheets(FeuilPage1$).Select 'retour
End Sub

job75 · 3 Octobre 2019

Pour mieux comprendre la macro de mon post #16 voyez le fichier joint.

La shape dont le coin supérieur gauche est en L10 est copiée.

job75 · 3 Octobre 2019

On peut aussi sélectionner la shape à copier, voyez ce fichier (2) :

VB:

Sub Copier_Shape()
Dim ad$, F As Worksheet, w As Worksheet, s As Shape
If TypeName(Selection) = "Range" Then MsgBox "Sélectionnez une shape...": Exit Sub
ad = Selection.TopLeftCell.Address
Set F = ActiveSheet
Application.ScreenUpdating = False
Selection.Copy
For Each w In Worksheets
    If w.Name <> F.Name Then
        For Each s In w.Shapes
            If s.TopLeftCell.Address = ad Then s.Delete
        Next s
        w.Visible = xlSheetVisible
        w.Activate
        w.Paste Destination:=w.Range(ad)
        ActiveCell.Activate
    End If
    F.Activate
    ActiveCell.Activate
Next w
End Sub

job75 · 3 Octobre 2019

Une chose curieuse chez moi sur Excel 2019 avec la macro précédente.

Quand je sélectionne (clic droit) le bouton Copier_Shape et que j'exécute la macro via Alt+F8 les boutons créés restent sélectionnés.

Pour éviter cela j'ai créé ce fichier (3) et la macro :

VB:

Sub Copier_Shape()
Dim ad$, F As Worksheet, w As Worksheet, s As Shape, ac As Range
If TypeName(Selection) = "Range" Then MsgBox "Sélectionnez une shape...": Exit Sub
ad = Selection.TopLeftCell.Address
Set F = ActiveSheet
Application.ScreenUpdating = False
Selection.Copy
For Each w In Worksheets
    If w.Name <> F.Name Then
        For Each s In w.Shapes
            If s.TopLeftCell.Address = ad Then s.Delete
        Next s
        w.Visible = xlSheetVisible
        w.Activate
        Set ac = ActiveCell
        w.Range(ad).Select
        w.Paste
        ac.Select
    End If
    F.Activate
    ActiveCell.Activate
Next w
End Sub

andrekn13 · 3 Octobre 2019

Job 75 félicitations

depuis ce matin je galère pour un truc tout bête : à force d'essayer de tout comprendre, j'ai tripler mon fichier, et au final j'ai adresser la mauvaise macro à mon shape; résultat, impossible d'adapter ces macro pour " si même shape" alors " réassigner la bonne macro"
Avec ta macro
1) enlève les doublons
2) se positionne de partout au même endroit
enfin bref tout simplement génial

je tiens à félicité tous les intervenants, je suis impressionné par l'efficacité d'une collaboration de groupe et votre gentillesse.
Je déplore pour moi-même que j'ai encore beaucoup de mal sur les syntaxes, passer des heures à essayer des codes du style :

For Each Sh In Feuille.Shapes
If Sh.Name = NomShap Then NomShap.Delete et impossible de comprendre pourquoi "NomShap.Delete" ça ne marcherait pas !
j'ai juste modifié vos codes ...… lol
Encore un grand merci

XL 2016 copier un objet sur toutes les feuilles

andrekn13

XLDnaute Occasionnel

job75

XLDnaute Barbatruc

andrekn13

XLDnaute Occasionnel

andrekn13

XLDnaute Occasionnel

Roland_M

XLDnaute Barbatruc

Pièces jointes

andrekn13

XLDnaute Occasionnel

Pièces jointes

Roland_M

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

andrekn13

XLDnaute Occasionnel

Discussions similaires