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
 

Pièces jointes

  • CopierImage.xlsm
    115.6 KB · Affichages: 5

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.
 

Pièces jointes

  • test(1).xlsm
    26.9 KB · Affichages: 18

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+
 

Pièces jointes

  • Capture d’écran 2019-12-18 à 17.02.29.png
    Capture d’écran 2019-12-18 à 17.02.29.png
    94.9 KB · Affichages: 8

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.
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 892
Membres
101 831
dernier inscrit
gillec