Align Shapes on Worksheets :

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