Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
XL 2010image dans une cellule que j'aimerais répéter sur une autre feuille
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.
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.
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
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.
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.
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
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.
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
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
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
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 D1059. 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.
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
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.
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 D1059, 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é.
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.
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.