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