asked on
Sub AlignMultipleShapes()
'PURPOSE: Align each shape in user's selection (first shape selected stays put)
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim Shp1 As Shape
Dim Shp2 As Shape
Dim x As Integer
Dim y As Integer
'Count How Many Shapes Are Selected
x = Windows(1).Selection.ShapeRange.Count
'Loop Through each selected Shape (align with first selected)
For y = 1 To x
If Shp1 Is Nothing Then
Set Shp1 = Windows(1).Selection.ShapeRange(y)
Else
Set Shp2 = Windows(1).Selection.ShapeRange(y)
'Align Left
Shp2.Left = Shp1.Left
'Align Right
Shp2.Left = Shp1.Left + (Shp1.Width - Shp2.Width)
'Align Top
Shp2.Top = Shp1.Top
'Align Bottom
Shp2.Top = Shp1.Top + (Shp1.Height - Shp2.Height)
'Align Middle (Horizontal Center)
Shp2.Top = Shp1.Top + ((Shp1.Height - Shp2.Height) / 2)
'Align Center (Vertical Center)
Shp2.Left = Shp1.Left + ((Shp1.Width - Shp2.Width) / 2)
End If
Next y
End Sub