Copie d'objet dans un endroit précis d'une cellule

[joums]

Bonjour, et bonne année
tous mes voeux et plein d'excel en 2010 lol


J'aimerai copier automatiquement un objet (shapes) dans un endroit précis de la cellule de destination.
Exemple : j'ai un carré qui se trouve en B2 et je voudrais le copier par macro vers la cellule D10.
Automatiquement l'objet se met en haut à gauche mais comment faire le placer à un endroit précis ?

Merci de votre aide
A +

 

[Roland_M]

Re : Copie d'objet dans un endroit précis d'une cellule

bonsoir

tu fais des essais en ajoutant quelques points à la position de ta cellule
exemple = TaCellule.Left + 5 (ou +10 . . . !? ) idem avec .Top

 

[joums]

Re : Copie d'objet dans un endroit précis d'une cellule

ok
merci c'est un début de réponse que je vais essayer
encore merci
je vous tiens au courant

 

[joums]

Re : Copie d'objet dans un endroit précis d'une cellule

Je n'est pas trouvé la solution
Peux tu m'en dire plus sur ce qu'il faudrait faire

merci

voici le code que j'ai commencé

Private Sub CommandButton1_Click()

    ActiveSheet.Shapes("Rectangle 1").Select
    Selection.Copy
   ' Range("E16").Select
  With Range("E16")
     .left = Range("E16").left + 20
'    .Top = Range("B5") + 10
End With
   
    ActiveSheet.PasteSpecial Format:="Image (métafichier amélioré)", Link:= _
        False, DisplayAsIcon:=False
    
End Sub

 

[pierrejean]

Re : Copie d'objet dans un endroit précis d'une cellule

bonjour a tous et meilleurs voeux pour 2010

Vois si tu peux t'inspirer de ceci (placement au milieu d'une cellule)

 

[joums]

Re : Copie d'objet dans un endroit précis d'une cellule

Bonjour,
Merci Pierre Jean pour ce début de réponse,
je vais essayer de m'en inspirer car ce que je souhaite faire c'est de pouvoir mettre plusieurs shapes dans une même cellule.
Par exemple shape1 plutôt à gauche, shape2 au mileu et shape3 vers la droite

Si quelqu'un aurait d'autre idées, merci

 

[pierrejean]

Re : Copie d'objet dans un endroit précis d'une cellule

Re

Avec un fichier exemple il serait plus facile de t'aider !!!

 

[joums]

Re : Copie d'objet dans un endroit précis d'une cellule

Bonjour Pierre jean,

voici un petit exemple dans le fichier ci-dessous
en espérant avoir été précis dans ma demande
merci

 

[pierrejean]

Re : Copie d'objet dans un endroit précis d'une cellule

Re

Vois si cela te convient
La macro tient en principe compte des dimensions de la cellule D17 (fais les varier pour observer)
Les figures sont alignées par le bas (mais on peut les aligner sur le milieu si necssaire)

 

[joums]

Re : Copie d'objet dans un endroit précis d'une cellule

merci pierre jean
je vais regarder le code que tu as mis, et je vais essayer de le comprendre pour l'adapter à ce que je souhaite faire
encore merci
bonne soirée

 

[pierrejean]

Re : Copie d'objet dans un endroit précis d'une cellule

Re

pour t'aider dans la comprehension:
le code commenté

Sub OnCopie()
Set cellule = Range("D17")
'nommer les dimensions (largeur L hauteur H) des figures et de la cellule
'ainsi que la position de la cellule
Lcyl = ActiveSheet.Shapes("AutoShape 6").Width
Hcyl = ActiveSheet.Shapes("AutoShape 6").Height
Lrect = ActiveSheet.Shapes("AutoShape 1").Width
Hrect = ActiveSheet.Shapes("AutoShape 1").Height
Ltri = ActiveSheet.Shapes("AutoShape 4").Width
Htri = ActiveSheet.Shapes("AutoShape 4").Height
PosHcell = cellule.Offset(1, 0).Top
PosGcell = cellule.Left
Lcell = cellule.Width
Hcell = cellule.Height
'calculer l'espace a mettre entre chaque figure
Ladistr = (Lcell - Lcyl - Lrect - Ltri) / 4
If Ladistr < 1 Then
  MsgBox ("cellule pas assez large pour recevoir les figures")
  Exit Sub
Else
'chercher la plus grande hauteur parmi celles des figures
 plushaut = 0
For n = 1 To 3
 If n = 1 Then Hfig = ActiveSheet.Shapes("AutoShape 6").Height
 If n = 2 Then Hfig = ActiveSheet.Shapes("AutoShape 1").Height
 If n = 3 Then Hfig = ActiveSheet.Shapes("AutoShape 4").Height
 If Hfig > plushaut Then plushaut = Hfig
Next n
'definir l'ecart entre le bas de la cellule et le bas des figures
Hdistr = (Hcell - plushaut) / 2
If Hdistr < 1 Then
  MsgBox ("cellule pas assez haute pour recevoir les figures")
  Exit Sub
End If
End If
'copier et nommer les figures
For n = 1 To 3
 If n = 1 Then fig = ActiveSheet.Shapes("AutoShape 6").Select
 If n = 2 Then fig = ActiveSheet.Shapes("AutoShape 1").Select
 If n = 3 Then fig = ActiveSheet.Shapes("AutoShape 4").Select
 Selection.Copy
 ActiveSheet.Paste
 Selection.Name = "Copie " & n
Next n
'Positionner les figures par rapport a la position de la cellule
ActiveSheet.Shapes("Copie 2").Left = PosGcell + Ladistr
ActiveSheet.Shapes("Copie 2").Top = PosHcell - Hdistr - ActiveSheet.Shapes("Copie 2").Height
ActiveSheet.Shapes("Copie 3").Left = PosGcell + 2 * Ladistr + ActiveSheet.Shapes("Copie 2").Width
ActiveSheet.Shapes("Copie 3").Top = PosHcell - Hdistr - ActiveSheet.Shapes("Copie 3").Height
ActiveSheet.Shapes("Copie 1").Left = PosGcell + 3 * Ladistr + ActiveSheet.Shapes("Copie 2").Width + ActiveSheet.Shapes("Copie 3").Width
ActiveSheet.Shapes("Copie 1").Top = PosHcell - Hdistr - ActiveSheet.Shapes("Copie 1").Height
Range("A1").Select
End Sub