How to centre image in merged cells

[craigy111]

Hello all.
I require a little guidance on how to centre an image within 2 merged cells the code I have been using to centre an image in one cell does not work for 2 cells. No matter how I try I just cant get it to work.
Is there a way to alter the code to allow for this. See bellow for the code I am using:

 Public Sub FitImagetoCell()'Insert Picture to Cell and Centre
On Error GoTo NOT_SHAPE


With Selection
            .Left = .TopLeftCell.Left + (.TopLeftCell.Width - .Width) / 2
            .Top = .TopLeftCell.Top + (.TopLeftCell.Height - .Height) / 2
        End With
   Exit Sub
   
NOT_SHAPE:
MsgBox "Select a picture."
End Sub

 

[mrshl9898]

Are the cells equally sized? You could just remove the /2.

 

[mrshl9898]

If the same Width

With ActiveSheet.Shapes("Picture 1")
.Top = Range("A1").Top + (Range("A1").Height - .Height) / 2
.Left = Range("A1").Left + Range("A1").Width - (.Width / 2)
End With

 

[shg]

Public Sub CenterInCell()
  Dim r As Range
  
  On Error GoTo Oops

  With Selection
    Set r = .TopLeftCell.MergeArea
    .Left = r.Left + (r.Width - .Width) / 2
    .Top = r.Top + (r.Height - .Height) / 2
  End With
  Exit Sub

Oops:
  MsgBox "Select a picture."
End Sub

 

[craigy111]

Thank you for the code it works perfect.

Public Sub CenterInCell()
  Dim r As Range
  
  On Error GoTo Oops

  With Selection
    Set r = .TopLeftCell.MergeArea
    .Left = r.Left + (r.Width - .Width) / 2
    .Top = r.Top + (r.Height - .Height) / 2
  End With
  Exit Sub

Oops:
  MsgBox "Select a picture."
End Sub

[/QUOTE]