Position shapes to be centered in a cell

[James]

Hi, Ive got a question about how to re-position a shape (type 13).

Ive got a spreadsheet that has a bunch of little pictures nested each in its
own cell. what im trying to do is center the picture in the center of the
cell. Im getting an error on "selection.shaperange.incrementtop 10" what am i
doing wrong?

any help would be great, thanks in advance

For Each C In Activesheet.Range("E11:BF100")
C.Select
On Error Resume Next 'if no shape in that cell
Selection.ShapeRange.IncrementTop 10
Selection.ShapeRange.IncrementLeft -1
On Error GoTo 0
Next C

 

[p45cal]

Maybe you have Excel 2007 and it allows you to select shapes on a shee
in this way (Selection.ShapeRange (ie. a range of cells on a shee
doesn't have its own range of shapes)). Not in Excel 2003.
A sheet has its collection of shapes, and you can define your ow
shaperange to contain what shapes you like - you could even use eac
shape's TopLeftCell and BottomRightCell properties to help you decid
which shapes to include.
The following bit of code puts the centre of each shape on the activ
sheet on the centre of its TopLeftCell (a process which could wel
change the TopLeftCell property of the shape, especially if the shape i
bigger than that cell):Sub blah()
For Each shp In ActiveSheet.Shapes
Set xxx = shp.TopLeftCell
shp.Top = xxx.Top + xxx.Height / 2 - shp.Height / 2
shp.Left = xxx.Left + xxx.Width / 2 - shp.Width / 2
Next shp
End Sub
and a way, perhaps, of narrowing down just which shapes yo
want to move around:Sub blah()
For Each shp In ActiveSheet.Shapes
If Not Intersect(shp.TopLeftCell, Range("E11:BF100")) Is Nothin
Then
Set xxx = shp.TopLeftCell
shp.Top = xxx.Top + xxx.Height / 2 - shp.Height / 2
shp.Left = xxx.Left + xxx.Width / 2 - shp.Width / 2
End If
Next shp
End Su

 

[Dave Peterson]

Centering the pictures in a cell doesn't mean too much to me.

You could have the picture fill up the cell with no border--or have a large
border and a very small picture--or anything in between.

When I'm doing this kind of thing, I usually want the picture to fill the cell
(and not go outside the cell). That means I can shrink the height and width
(preservinging the aspect ratio, too).

Either way, this may give you a way to experiment with what you want:

Option Explicit
Sub testme()
Dim myPict As Picture
Dim myCell As Range
Dim myRngToInspect As Range
Dim myAspectRatio As Double

With ActiveSheet
Set myRngToInspect = .Range("E11:E20") 'E11:BF100 after finished testing

For Each myPict In .Pictures
Set myCell = myPict.TopLeftCell
If Intersect(myCell, myRngToInspect) Is Nothing Then
'outside that range, skip it
Else
With myPict
myAspectRatio = .Width / .Height
.ShapeRange.LockAspectRatio = msoTrue

.Left = myCell.Left
.Top = myCell.Top
.Height = myCell.Height
.Width = myAspectRatio * .Height
If .Width > myCell.Width Then
'too wide for the cell
'With the aspectratio locked, the
'reducing the width will reduce the height
.Width = myCell.Width
End If
End With
End If
Next myPict
End With

End Sub

 

[James]

Thank you for the help. p45cal that method worked great. I do have 2003 and
probably the reason for the error. thanks again!