VBA – Excel – Routine to position shapes in range

Routine to position shapes in worksheet based on specified ranges.

Note: Can use ‘print shape name‘ routine to create required list. See snippet below.

[code language=”vb”]
Sub RunPlaceShapeInRange()
‘Routine to place specified shape in specified range
Dim CWS As Worksheet

Set CWS = ChartSht ‘Change this to specific worksheet object

‘Uncomment line below to specify worksheet name
‘Set CWS = ThisWorkbook.Worksheets("WorksheetName")

Call PlaceShapeInRange("Shape No1", "D2:G4", CWS)
End Sub

Sub PlaceShapeInRange(ShapeName As String, RangeStr As String, InWS As Worksheet)
‘Routine to place specified shape in specified range. Run from: RunPlaceShapeInRange

Dim CShape As Shape
Dim CRange As Range

Set CShape = InWS.Shapes(ShapeName)
Set CRange = InWS.Range(RangeStr)

CShape.Left = CRange.Left
CShape.Top = CRange.Top
CShape.Width = CRange.Width
CShape.Height = CRange.Height

End Sub
[/code]

To position a lot of shapes (which is the main point of this routine), a list can be quickly generated using the ‘print shape names‘ routine and inserting something like:

[code language=”vb”]
Debug.Print "Call PlaceShapeInRange(" & Chr(34) & CShape.Name & Chr(34) & ", " & Chr(34) & "Range" & Chr(34) & ", CWS)"
[/code]

in the appropriate position. This will produce something like:

Call PlaceShapeInRange(“SalesChart”, “Range”, CWS)
Call PlaceShapeInRange(“Salesman”, “Range”, CWS)
Call PlaceShapeInRange(“Current (Y/N)”, “Range”, CWS)

Which then requires the specified range to be typed in.

Example:
[code language=”vb”]
Sub RunPlaceShapeInRange()
‘Routine to place specified shape in specified range
Dim CWS As Worksheet

Set CWS = ChartSht ‘Change this to specific worksheet object

‘Uncomment line below to specify worksheet name
‘Set CWS = ThisWorkbook.Worksheets("WorksheetName")

Call PlaceShapeInRange("SalesChart", "I6:V38", CWS)
Call PlaceShapeInRange("Salesman", "F6:G25", CWS)
Call PlaceShapeInRange("Current (Y/N)", "F40:G44", CWS)
Call PlaceShapeInRange("Year", "I2:P4", CWS)
Call PlaceShapeInRange("Acc size", "X2:AF4", CWS)

End Sub
[/code]