Move and resize a worksheet shape object to cover a given worksheet range
2016-10-07 Worksheets 2 766
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