XL 2010 image dans une cellule que j'aimerais répéter sur une autre feuille

juliensav

XLDnaute Junior
Bonjour,

J'ai une feuille qui s'appelle "INTERNE" que j'ai dans la colonne C10 à C19, des images que j'insère.

J'aimerais que lorsque j'insérer une image en C10 par exemple, celle-ci soit directement copiée dans les feuilles suivantes :
Feuille "Soumission-Designer" en B10.
Feuille "Soumission-Client" en B10.

Est-ce possible de faire cette manipulation ?

Merci de votre aide.

J'utilise excel 2010 sur terminal serveur ou version MAC 16.3.
 

job75

XLDnaute Barbatruc
Bonsoir juliensav,

Placez cette macro dans le ThisWorkbook du classeur :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "Soumission-Designer" And Sh.Name <> "Soumission-Client" Then Exit Sub 'noms des feuilles à adapter
Dim o As Object
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
'---RAZ---
For Each o In Sh.DrawingObjects
    If Not Intersect(o.TopLeftCell, Range("B10:B19")) Then o.Delete
Next
'---copie les objets---
With Sheets("INTERNE") 'nom de la feuille à adapter
    For Each o In .DrawingObjects
        If Not Intersect(o.TopLeftCell, .Range("C10:C19")) Then o.Placement = 2 'propriété "copier sans dimensionner"
    Next
    .Range("C10:C19").Copy Sh.Range("B10:B19") 'copier-coller
End With
End Sub
La plage source C10:C19 est copiée et collée dans la plage B10:B19 de destination, avec ses images, quand on active la feuille.

A+
 

Xtian_Québec

XLDnaute Occasionnel
Bonjour Juliensav
Si ton image dans C10 n'est pas plus grande que le format de ta cellule, un simple copier/coller fonctionnera.
J'ai testé avec une cellule qui a le format Largeur 44 et hauteur 180 et j'ai insérer une image 6 cm x 8 cm et le code copie l'image dans l'autre feuille.
La grandeur des cellules qui reçoivent l'image doivent être de la même dimension.
Le code est simple, il serait possible de faire un code plus sophistiqué pour gérer la grandeur des cellules, propriétés de l'image à copier et d'autres paramètres mais si les cellules ont la bonne dimension par rapport à l'image, un simple copier/colle fait le travail...


VB:
Sub CopierImage()
    Sheets("INTERNE").Range("B10").Select
    Selection.Copy
    Sheets("Soumission-Designer").Activate
    Sheets("Soumission-Designer").Range("B10").Select
    ActiveSheet.Paste
    Sheets("Soumission-Designer").Range("A1").Select
    Sheets("Soumission-Client").Activate
    Sheets("Soumission-Client").Range("B10").Select
    ActiveSheet.Paste
    Sheets("Soumission-Client").Range("A1").Select
    Sheets("INTERNE").Activate
End Sub
Xtian_Quebec
 

Fichiers joints

Xtian_Québec

XLDnaute Occasionnel
RE Job75 et JulienSav
Copier/coller peut fonctionner si le format des cellules est identiques mais ton code est plus SOPHISTIQUÉ, c'est exactement ce que je disais...Je suis allé au plus simple, toi tu y a mis le paquet...Bravo.

A+
 

juliensav

XLDnaute Junior
BONJOUR Job75,

Je ne réussi pas à faire fonctionner votre formule. Je l'ai bien inséré à l'endroit indiqué, mais rien à faire...Et je ne comprend pas pourquoi.

Bonsoir juliensav,

Placez cette macro dans le ThisWorkbook du classeur :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "Soumission-Designer" And Sh.Name <> "Soumission-Client" Then Exit Sub 'noms des feuilles à adapter
Dim o As Object
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
'---RAZ---
For Each o In Sh.DrawingObjects
    If Not Intersect(o.TopLeftCell, Range("B10:B19")) Then o.Delete
Next
'---copie les objets---
With Sheets("INTERNE") 'nom de la feuille à adapter
    For Each o In .DrawingObjects
        If Not Intersect(o.TopLeftCell, .Range("C10:C19")) Then o.Placement = 2 'propriété "copier sans dimensionner"
    Next
    .Range("C10:C19").Copy Sh.Range("B10:B19") 'copier-coller
End With
End Sub
La plage source C10:C19 est copiée et collée dans la plage B10:B19 de destination, avec ses images, quand on active la feuille.

A+
 

job75

XLDnaute Barbatruc
Bonsoir Xtian_Québec,

Bien comprendre, pour que le copier-coller d'une plage copie-colle les images il faut 2 choses :

- que l'option avancée d'Excel soit cochée (menu Fichier-Options)

- que la propriété Placement de l'image ne soit pas 3 (Ne pas déplacer ou dimensionner avec les cellules).

A+
 

job75

XLDnaute Barbatruc
Au post #1 vous nous dites que les images de la feuille "INTERNE" sont dans la plage C10:C19, pas en colonne B !!!

Alors je les ai mises en colonne C dans le fichier .xlsm joint.

De plus les noms des feuilles étant maintenant en MAJUSCULES il faut adapter la macro :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "SOUMISSION-DESIGNER" And Sh.Name <> "SOUMISSION-CLIENT" Then Exit Sub 'noms des feuilles à adapter
Dim o As Object
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
'---RAZ---
For Each o In Sh.DrawingObjects
    If Not Intersect(o.TopLeftCell, Range("B10:B19")) Then o.Delete
Next
'---copie les objets---
With Sheets("INTERNE") 'nom de la feuille à adapter
    For Each o In .DrawingObjects
        If Not Intersect(o.TopLeftCell, .Range("C10:C19")) Then o.Placement = 2 'propriété "déplacer sans dimensionner"
    Next
    .Range("C10:C19").Copy Sh.Range("B10:B19") 'copier-coller
End With
End Sub
Bonne nuit.
 

Fichiers joints

juliensav

XLDnaute Junior
BonjourJob75

J'ai testé votre fichier et le tout fonctionne. Par contre quand je l'insére dans mon fichier principal, ca ne marche plus. Je valide le tout et vous reviens au besoin.

Un énorme merci de m'avoir aidé.


Au post #1 vous nous dites que les images de la feuille "INTERNE" sont dans la plage C10:C19, pas en colonne B !!!

Alors je les ai mises en colonne C dans le fichier .xlsm joint.

De plus les noms des feuilles étant maintenant en MAJUSCULES il faut adapter la macro :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "SOUMISSION-DESIGNER" And Sh.Name <> "SOUMISSION-CLIENT" Then Exit Sub 'noms des feuilles à adapter
Dim o As Object
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
'---RAZ---
For Each o In Sh.DrawingObjects
    If Not Intersect(o.TopLeftCell, Range("B10:B19")) Then o.Delete
Next
'---copie les objets---
With Sheets("INTERNE") 'nom de la feuille à adapter
    For Each o In .DrawingObjects
        If Not Intersect(o.TopLeftCell, .Range("C10:C19")) Then o.Placement = 2 'propriété "déplacer sans dimensionner"
    Next
    .Range("C10:C19").Copy Sh.Range("B10:B19") 'copier-coller
End With
End Sub
Bonne nuit.
 

juliensav

XLDnaute Junior
Bonjour Job75,

Cette méthode est vraiment idéale. Par contre tel que discuté la dernière fois, je n'arrive pas à insérer votre formule dans mon fichier et la faire fonctionner. De plus, j'ai largement modifié mon fichier principal et certaines données ont changées.

J'aimerais voir si quelqu'un de la communauté serait en mesure de me donner un coup de main. Les images sont dans la feuille "DocumentPrincipal" dans la colonne D10 à D59. Je joint mon fichier principal dans un lien wetransfert, car il est malheureusement trop pesant.
https://we.tl/t-ucPq55WYzN

Je désires que lorsque je positionne une image dans une cellule D10 à D59 de ma feuille "DocumentPrincipal", celle-ci soit automatiquement dirigée vers une autre cellule d'une autre page. Si par exemple, je décides de supprimer l'image en question dans une cellule situé entre D10 et D59, et bien celle-ci sera également supprimer des autres pages. En fait, tel que le fichier test que Job75 a crée. C'est exactement ce que je recherches, mais adapté maintenant à ma situation.

Pour les images de D10 à D19 de la feuille "DocumentPrincipal", j'aimerais que ceux-ci soit affichées tel un miroir dans les cellule B9 à B18 de la feuille "DESIGN-1A" et CLIENT-1A.

Pour les images de D20 à D29 de la feuille "DocumentPrincipal", j'aimerais que ceux-ci soit affichées tel un miroir dans les cellule B9 à B18 de la feuille "DESIGN-2A" et CLIENT-2A.

Pour les images de D30 à D39 de la feuille "DocumentPrincipal", j'aimerais que ceux-ci soit affichées tel un miroir dans les cellule B9 à B18 de la feuille "DESIGN-3A" et CLIENT-3A.

Pour les images de D40 à D49 de la feuille "DocumentPrincipal", j'aimerais que ceux-ci soit affichées tel un miroir dans les cellule B9 à B18 de la feuille "DESIGN-2A" et CLIENT-2A.

Pour les images de D50 à D59 de la feuille "DocumentPrincipal", j'aimerais que ceux-ci soit affichées tel un miroir dans les cellule B9 à B18 de la feuille "DESIGN-2B" et CLIENT-2B.

De plus je voudrais que l'image soit affichée tel un miroir comme suit :
D10 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L1".
D11 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L2".
D12 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L3".
D13 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L4".
D14 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L5".
D15 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L6".
D16 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L7".
D17 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L8".
D18 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L9".
D19 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L10".
D20 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L11".
D21 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L12".
D22 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L13".
D23 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L14".
D24 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L15".
D25 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L16".
D26 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L17".
D27 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L18".
D28 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L19".
D29 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L20".
D30 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L21".
D31 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L22".
D32 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L23".
D33 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L24".
D34 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L25".
D35 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L26".
D36 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L27".
D37 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L28".
D38 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L29".
D39 "DocumentPrincipal" vers la colonne fusionnée C15:I38 de la feuille "L30".

Un énorme merci de votre aide.
Voici le lien web pour télécharger le fichier :
https://we.tl/t-ucPq55WYzN

Au post #1 vous nous dites que les images de la feuille "INTERNE" sont dans la plage C10:C19, pas en colonne B !!!

Alors je les ai mises en colonne C dans le fichier .xlsm joint.

De plus les noms des feuilles étant maintenant en MAJUSCULES il faut adapter la macro :
VB:
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If Sh.Name <> "SOUMISSION-DESIGNER" And Sh.Name <> "SOUMISSION-CLIENT" Then Exit Sub 'noms des feuilles à adapter
Dim o As Object
Application.ScreenUpdating = False
Application.CopyObjectsWithCells = True 'au cas où...
'---RAZ---
For Each o In Sh.DrawingObjects
    If Not Intersect(o.TopLeftCell, Range("B10:B19")) Then o.Delete
Next
'---copie les objets---
With Sheets("INTERNE") 'nom de la feuille à adapter
    For Each o In .DrawingObjects
        If Not Intersect(o.TopLeftCell, .Range("C10:C19")) Then o.Placement = 2 'propriété "déplacer sans dimensionner"
    Next
    .Range("C10:C19").Copy Sh.Range("B10:B19") 'copier-coller
End With
End Sub
Bonne nuit.
 
Dernière édition:

job75

XLDnaute Barbatruc
Bonsoir juliensav,

Il va falloir que vous bossiez un peu car vu mon âge je deviens fainéant.

1) Placez cette macro dans le code de la feuille "DESIGN-1A" et des autres feuilles désirées (en adaptant la plage source) :
VB:
Private Sub Worksheet_Activate()
Dim o As Object
With [B9:B18]
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then o.Delete 'RAZ
    Next
    Sheets("DocumentPrincipal").[D10:D19].Copy .Cells(1) 'adapter la plage source
End With
End Sub
2) Placez cette macro dans le code de la feuille "L1" et des autres feuilles désirées (en adaptant la cellule source) :
VB:
Private Sub Worksheet_Activate()
Dim o As Object
With [C15:I38]
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then o.Delete 'RAZ
    Next
    .UnMerge 'défusionne
    Sheets("DocumentPrincipal").[D10].Copy .Cells(1) 'adapter la cellule source
    .ClearContents
    .Merge 'fusionne
    For Each o In DrawingObjects 'pour positionner l'image au centre
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then
            o.Top = .Top + (.Height - o.Height) / 2
            o.Left = .Left + (.Width - o.Width) / 2
            Exit For
        End If
    Next
End With
End Sub
A+
 

juliensav

XLDnaute Junior
Bonsoir Job75,

Vous êtes très efficace. Le tout fonctionne a merveille. J'ai fais toutes mes feuilles en quelques minutes.

La seul chose qui cloche c"est la la formule 2. L'image est bel et bien centré dans les cellules fusionnées C15:I38, par contre l'image garde le même format que dans la page "DocumentPrincipal" dans la colonne D10:D59. Il faudrait que l'image qui est copiée dans la feuille exemple L1 C15:I38 soit proportionnel à l'encadré...Est-ce possible ?

Je met une photo en pièce jointe pour que vous puissiez vous ce que ca fait.

Merci encore 1000 fois.

Bonsoir juliensav,

Il va falloir que vous bossiez un peu car vu mon âge je deviens fainéant.

1) Placez cette macro dans le code de la feuille "DESIGN-1A" et des autres feuilles désirées (en adaptant la plage source) :
VB:
Private Sub Worksheet_Activate()
Dim o As Object
With [B9:B18]
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then o.Delete 'RAZ
    Next
    Sheets("DocumentPrincipal").[D10:D19].Copy .Cells(1) 'adapter la plage source
End With
End Sub
2) Placez cette macro dans le code de la feuille "L1" et des autres feuilles désirées (en adaptant la cellule source) :
VB:
Private Sub Worksheet_Activate()
Dim o As Object
With [C15:I38]
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then o.Delete 'RAZ
    Next
    .UnMerge 'défusionne
    Sheets("DocumentPrincipal").[D10].Copy .Cells(1) 'adapter la cellule source
    .ClearContents
    .Merge 'fusionne
    For Each o In DrawingObjects 'pour positionner l'image au centre
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then
            o.Top = .Top + (.Height - o.Height) / 2
            o.Left = .Left + (.Width - o.Width) / 2
            Exit For
        End If
    Next
End With
End Sub
A+
 

Fichiers joints

job75

XLDnaute Barbatruc
Bonjour juliensav, le forum,

Oui pardon, pour la feuille "L1" j'ai oublié de dimensionner l'image, il suffit d'ajouter 3 lignes de code :
VB:
Private Sub Worksheet_Activate()
Dim o As Object
With [C15:I38]
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then o.Delete 'RAZ
    Next
    .UnMerge 'défusionne
    Sheets("DocumentPrincipal").[D10].Copy .Cells(1) 'adapter la cellule source
    .ClearContents
    .Merge 'fusionne
    '---dimensionne et positionne l'image au centre---
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then
            o.ShapeRange.LockAspectRatio = True 'verrouille le rapport hauteur/largeur
            o.Height = .Height - 4
            If o.Width > .Width - 4 Then o.Width = .Width - 4
            o.Top = .Top + (.Height - o.Height) / 2
            o.Left = .Left + (.Width - o.Width) / 2
            Exit For
        End If
    Next
End With
End Sub
Edit : dans la feuille "DocumentPrincipal" toutes les images doivent avoir la propriété "Déplacer sans dimensionner avec les cellules.

J'ai vérifié, c'est bien le cas.

Bonne journée.
 
Dernière édition:

juliensav

XLDnaute Junior
Bon matin Job75,

Tout est parfait. J'aimerais savoir s'il serait possible d'avoir une formule que je vais lier à une macro (bouton) sur ma page "DocumentPrincipal" qui va rafraichir les images automatiques dans les autres feuilles. Car je remarque que si je modifie une image dans la colonne D10:D59, je dois obligatoirement aller dans chacune des feuilles pour m'assurer que l'image soit modifié. J'imagine que c'est à cause que votre formule s'active lorsque nous sommes sur la feuille active seulement.

Encore merci pour votre support, c'est grandement apprécié.

Bonjour juliensav, le forum,

Oui pardon, pour la feuille "L1" j'ai oublié de dimensionner l'image, il suffit d'ajouter 3 lignes de code :

VB:
Private Sub Worksheet_Activate()
Dim o As Object
With [C15:I38]
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then o.Delete 'RAZ
    Next
    .UnMerge 'défusionne
    Sheets("DocumentPrincipal").[D10].Copy .Cells(1) 'adapter la cellule source
    .ClearContents
    .Merge 'fusionne
    '---dimensionne et positionne l'image au centre---
    For Each o In DrawingObjects
        If Not Intersect(o.TopLeftCell, .Cells) Is Nothing Then
            o.ShapeRange.LockAspectRatio = True 'verrouille le rapport hauteur/largeur
            o.Height = .Height - 4
            If o.Width > .Width - 4 Then o.Width = .Width - 4
            o.Top = .Top + (.Height - o.Height) / 2
            o.Left = .Left + (.Width - o.Width) / 2
            Exit For
        End If
    Next
End With
End Sub
Edit : dans la feuille "DocumentPrincipal" toutes les images doivent avoir la propriété "Déplacer sans dimensionner avec les cellules.

J'ai vérifié, c'est bien le cas.

Bonne journée.
 

job75

XLDnaute Barbatruc
Faire les mises à jour en activant les feuilles est la meilleur solution : chaque feuille est traitée quand c'est nécessaire.

Bien sûr on pourrait envisager un bouton qui activerait toutes les feuilles mais c'est tout à fait inutile.
 

job75

XLDnaute Barbatruc
Il existe une méthode très simple pour copier des images sans utiliser VBA (donc fichier .xlsx), voici un exemple.

Activez la feuille "L1" et sélectionnez la cellule (fusionnée) C15.

Menu Accueil => Copier => Copier comme image => Coller.

Cliquez sur l'image (vierge) ainsi formée et dans la barre de formule entrez la formule de liaison =DocumentPrincipal!D10

C'est tout, faites la même chose pour toutes les cellules de destination.

A+
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas