Select a range of cells in Excel - creates shapes containing the text in the cells

CreateShapes.bas

Sub CreateShapes()
i = 0
For Each cell In Selection
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, i * 20, i * 20, 72, 20)
    With shp.TextFrame2
        .VerticalAnchor = msoAnchorMiddle
        .TextRange.ParagraphFormat.Alignment = msoAlignCenter
        .AutoSize = msoAutoSizeShapeToFitText
        .WordWrap = msoFalse
        .TextRange.Characters.Text = cell.Value
    End With
    i = i + 1
Next

End Sub