Move and resize a worksheet shape object to cover a given worksheet range

 2016-10-07    Worksheets    0    117

The functions below can be used to move and resize a worksheet object so that it covers a cell range. Very useful when you want to move and size chart objects for a dashboard report.

Function MoveAndResizeShapeToRange(objShape As Shape, objRange As Range) As Boolean
' updated 2016-10-05 by OPE
' moves and resizes a worksheet object (objShape) so that it fits over a cell range (objRange)
' objShape must be located in the same worksheet as objRange
' returns True if objShape was successfully resized and moved
Dim varPos As Variant, OK As Boolean
    If objShape Is Nothing Then Exit Function
    If objRange Is Nothing Then Exit Function
    If objShape.Parent.Name <> objRange.Parent.Name Then Exit Function
    
    varPos = GetRangePosAndSize(objRange)
    If Not IsArray(varPos) Then Exit Function
    
    OK = True
    On Error GoTo ErrorMovingShape
    With objShape
        .Top = varPos(1)
        .Left = varPos(2)
        .Width = varPos(3)
        .Height = varPos(4)
    End With
    On Error GoTo 0
    MoveAndResizeShapeToRange = OK
    Exit Function
    
ErrorMovingShape:
    OK = False
    Resume Next
End Function

Function GetRangePosAndSize(objRange As Range) As Variant
' updated 2016-10-05 by OPE
' returns an array with top, left, width and height for cell range objRange
' if objRange has multiple areas, information from the first area will be returned
' this function will fail if objRange contains the last worksheet row and/or column (very unlikely)
Dim arrValues(1 To 4) As Long, r As Long, c As Long
    GetRangePosAndSize = False
    If objRange Is Nothing Then Exit Function
    
    ' set default values to be returned if function fails
    arrValues(1) = -1
    arrValues(2) = -1
    arrValues(3) = -1
    arrValues(4) = -1
    On Error Resume Next ' ignore errors
    With objRange.Areas(1)
        r = .Rows.Count
        c = .Columns.Count
        With .Range("A1")
            arrValues(1) = .Top
            arrValues(2) = .Left
            With .Offset(r, c)
                arrValues(3) = .Left - arrValues(2) ' width
                arrValues(4) = .Top - arrValues(1) ' height
            End With
        End With
    End With
    On Error GoTo 0 ' resume normal error handling
    GetRangePosAndSize = arrValues
End Function

Sub ExampleMoveAndResizeShapeToRange()
Dim objShape As Shape
    'Set objShape = ActiveSheet.Shapes(1)
    Set objShape = ActiveSheet.Shapes("Chart 1")
    MoveAndResizeShapeToRange objShape, Range("H1:P11")
    'MoveAndResizeShapeToRange objShape, Selection
    ActiveWindow.RangeSelection.Select
    Set objShape = Nothing
End Sub


Leave a comment:

Your comment will only be published after it has been moderated and found spam free.
Your e-mail address will only be used to display your Gravatar.