Center a Shape in a Cell

[Izran]

Seems like a simple enough problem. I have a shape that I am pasting
into several sheets in a workbook. I can paste them to the cell I
want, but I need to find a way to center the said shape in the target
cell.

 

[Duncan]

try using (replace autoshape6 with name of shape)

ActiveSheet.Shapes("AutoShape 6").Select
Selection.ShapeRange.IncrementLeft 0.75
Selection.ShapeRange.IncrementTop -1.5

and play with the increments until you get the desired effect.

HTH

Duncan

 

[Izran]

The problem with that is that the shape to be transferred can vary in
size. They are copies of signatures and depending on the size of the
name the size of the shape differs. The cell they are to be pasted
into can handle the largest signature. I'm just finding it difficult
to find a way to basically center the copied and pasted signature in
the target cell.

 

[Izran]

In short I want the center of the shape placed in teh center of the
cell.

 

[Duncan]

I am sure that someone more experienced than me would have a solution
but to me it looks like the problem is that the shape is not in the
cell but actually over the cell that is selected when you paste the
shape,

can you paste your code in that puts the shape in the cell?

 

[Izran]

Sheets("Signatures").Select
ActiveSheet.Shapes("Init_1").Select
Selection.Copy
Sheets("Indy 1A1-3").Select
Range("V59:AA59").Select
ActiveSheet.Paste

And yes that is the problem. It doesn't paste it centered.

 

[Duncan]

im playing with selection.Placement = xlMoveAndSize but that will not
help and i cannot find anything to center over the cell, I dont know
what I would do except work out the lengths of each signature and do a
complicated if else statement so that if it recognises the name of the
shape then it increments it by the right amount. that would take a fair
while to work out and code though and I am sure there must be someone
out there that knows the right way to go about it.

If you are pasting the shapes one by one though then it wouldnt be too
much trouble to work out the increments for each one and do it straight
after the paste?


sorry i couldnt help.

Duncan

 

[JE McGimpsey]

One way:

With ActiveSheet.Shapes("MyShape")
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
.Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
End With

 

[Izran]

Got it. Thanks for the input. My solution actually was close to
McGimpseys':

Dim Signature As Shape

Sheets("Signatures").Select

Set Signature = ActiveSheet.Shapes("Init_1")

Signature.Select
Selection.Copy
Sheets("Indy 1A1-3").Select
Range("V59:AA59").Select
ActiveSheet.Paste

With Cells(ActiveCell.Row, "V")
Selection.Top = .Top
Selection.Left = .Left
End With

Selection.ShapeRange.IncrementLeft ((Range("V59:AA59").Width -
Signature.Width) / 2)
Selection.ShapeRange.IncrementTop ((Range("V59:AA59").Height -
Signature.Height) / 2)

 

[Ardus Petus]

Sub centershape()
With ActiveSheet.Shapes("Signature")
.Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
.Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
End With
End Sub

HTH