Centering Image in Merged Range

My end goal is to center an image in a merged range. I found code that will allow me to center an image in a cell but I cant seem to figure out how to (or even if its possible to) modify it to work on a merged range instead of a single cell.

If anyone has any idea about how to modify this code, or a different way all together to go about this any help would be much appreciated!

In the attached file ctrl+w will center an object in the selected cell provided that the top right corner of the object is located in that cell.

Hi there,

Take a look at the attached version of your workbook and see if it does what you need. It uses the following code:

Option Private Module
Option Explicit


'=========================================================================================
'=========================================================================================


Sub CheckShapeAndRange()

    Dim rTargetRange    As Range
    Dim bShapeFound     As Boolean
    Dim rCell           As Range
    Dim shp             As Shape

    If TypeName(Selection) = "Range" Then

          Set rTargetRange = Selection

          For Each shp In ActiveSheet.Shapes

              bShapeFound = False

              For Each rCell In rTargetRange.Cells

                  If rCell.Address = shp.TopLeftCell.Address Then
                      bShapeFound = True
                      Exit For
                  End If

              Next rCell

              If bShapeFound = True Then

                    Call CentreShape(rTargetRange:=rTargetRange, shp:=shp)
                    Exit For

              Else: MsgBox "The selected cells do not contain a Shape", vbExclamation
                    Exit For

              End If

          Next shp

    Else: MsgBox "Select a range before using this feature", vbExclamation

    End If

End Sub


'=========================================================================================
'=========================================================================================


Sub CentreShape(rTargetRange As Range, shp As Shape)

    Dim dRangeBottom    As Double
    Dim dRangeRight     As Double
    Dim rBottomCell     As Range
    Dim rRightCell      As Range
    Dim dShapeLeft      As Double
    Dim dRangeLeft      As Double
    Dim dRangeTop       As Double
    Dim dShapeTop       As Double

    With rTargetRange

        dRangeTop = .Cells(1, 1).Top

        Set rBottomCell = .Cells(.Cells.Count)
        dRangeBottom = rBottomCell.Top + rBottomCell.Height

        dRangeLeft = .Cells(1, 1).Left

        Set rRightCell = .Cells(.Cells.Count)
        dRangeRight = rRightCell.Left + rRightCell.Width

        If (shp.Width <= (dRangeRight - dRangeLeft)) And _
           (shp.Height <= (dRangeBottom - dRangeTop)) Then

              dShapeTop = dRangeTop + ((dRangeBottom - dRangeTop - shp.Height) / 2)

              dShapeLeft = dRangeLeft + ((dRangeRight - dRangeLeft - shp.Width) / 2)

              shp.Top = dShapeTop
              shp.Left = dShapeLeft

        Else: MsgBox "The Shape cannot be accommodated within the selected range", _
                      vbExclamation

        End If

    End With

End Sub

Hope this helps - please let me know how you get on.

Regards,

Greg M

Thanks Greg, this is exactly what I was trying to accomplish, I just didn't have enough VBA experience to code it! But looking at your code, it makes total sense.

Spoke a bit too soon - if I want to assign this to a hotkey instead of a button, how would I go about doing that?

AHHHH - I was wondering why it wasn't showing up in the macro menu. Removed that and it popped right up. I did a quick Google search and understand the basic use of that command but im curious why you included it in the first place?

Also, it only seems to be working on the first range I use it on. I get an error saying there is no shape in the range if I try to execute it on a second range. In the attached it works as expected in range 1, but in 2 and 3 it insists there isn't a shape there. Any thoughts?

Thanks,
Simon

Hi again Simon,

Dang it all! That's what happens when you test your code on a "nice little workbook" instead of on a "real" one!

The attached workbook contains a new version of the "CheckShapeAndRange" routine (shown below), and appears to do what you need.

Sub CheckShapeAndRange()

    Dim rTargetRange    As Range
    Dim bShapeFound     As Boolean
    Dim rCell           As Range
    Dim shp             As Shape

    If TypeName(Selection) = "Range" Then

          Set rTargetRange = Selection

          For Each shp In ActiveSheet.Shapes

              bShapeFound = False

              For Each rCell In rTargetRange.Cells

                  If rCell.Address = shp.TopLeftCell.Address Then
                      bShapeFound = True
                      Exit For
                  End If

              Next rCell

              If bShapeFound = True Then

                    Call CentreShape(rTargetRange:=rTargetRange, shp:=shp)
                    Exit For

              End If

          Next shp

          If bShapeFound = False Then
              MsgBox "The selected cells do not contain a Shape", vbExclamation
          End If

    Else: MsgBox "Select a range before using this feature", vbExclamation

    End If

End Sub

Regarding:

but I'm curious why you included it in the first place?

I normally include the "Option Private Module" statement to prevent macros being made available to "curious Users" via the Macro menu - I prefer to make macros available via CommandButtons on a worksheet or icons on the Ribbon.


Hope the above helps - as always, please let me know how you get on.

Regards,

Greg M

That did it! Thanks again for all your help. And for the explanation - makes sense in terms of keeping prying hands off your code!

Best,
Simon

You're welcome - glad to have helped out.

Feel free to shout if there's anything else you need.

Regards,

Greg M