Sub ShapeTest()

Dim ActiveShape As Shape
Dim ShapeCell As Range

Application.ScreenUpdating = False

Set ShapeCell = ActiveSheet.Range("A1")
Set ActiveShape = ActiveSheet.Shapes.AddShape(msoShapeRectangle, ShapeCell.Left, ShapeCell.Top, ShapeCell.Width, ShapeCell.Height)

ActiveSheet.Rows(1).Insert shift:=xlShiftDown

Application.ScreenUpdating = True

End Sub