Many Time we have Lot of Shapes On a Worksheets and we have to Align All those Shapes . This is a Code snippet to Make this Task easy.
Sub MakeMyShapes()
Dim intICounter As Integer
Dim shpShape As Shape
Dim sngHeight As Single
Dim sngWidth As Single
Dim IntNShapes As Integer
Dim intleft As Integer
Dim intTop As Integer
Dim bytRow As Byte
Dim intMaxH As Integer
Dim intMaxW As Integer
Dim intTempArr() As Integer
bytRow = Application.InputBox("Please enter Number of Rows (0-255)")
With ActiveSheet
IntNShapes = .Shapes.Count
intleft = .Shapes(1).Left
intTop = .Shapes(1).Top
sngHeight = .Shapes(1).Height
sngWidth = .Shapes(1).Width
ReDim intTempArr(IntNShapes)
For intICounter = 0 To IntNShapes - 1
intTempArr(intICounter) = .Shapes(intICounter + 1).Height
Next
intMaxH = WorksheetFunction.Max(intTempArr)
For intICounter = 0 To IntNShapes - 1
intTempArr(intICounter) = .Shapes(intICounter).Width
Next
intMaxW = WorksheetFunction.Max(intTempArr)
For intICounter = 1 To IntNShapes
.Shapes(intICounter).Left = intleft
.Shapes(intICounter).Top = intTop
If intICounter Mod bytRow = 0 Then
intleft = .Shapes(intICounter + 1 - bytRow).Left + sngWidth
intTop = .Shapes(1).Top
Else
intleft = .Shapes(intICounter).Left
intTop = .Shapes(intICounter).Top + sngHeight
End If
.Shapes(intICounter).TextFrame.Characters.Text = intICounter
Next
End With
End Sub
