Sub GetShapeProperties()
    Dim sShapes As Shape, lLoop As Long
    Dim wsStart As Worksheet, WsNew As Worksheet
  
    Set wsStart = ActiveSheet
    Set WsNew = Sheets.Add

    WsNew.Range("A1:F1") = _
     Array("Shape Name", "Shape Type", "Height", "Width", "Left", "Top")

    For Each sShapes In wsStart.Shapes

        lLoop = lLoop + 1

        With sShapes

            'Add shape properties
            WsNew.Cells(lLoop + 1, 1) = .Name
            WsNew.Cells(lLoop + 1, 2) = .OLEFormat.Object.Name
            WsNew.Cells(lLoop + 1, 3) = .Height
            WsNew.Cells(lLoop + 1, 4) = .Width
            WsNew.Cells(lLoop + 1, 5) = .Left
            WsNew.Cells(lLoop + 1, 6) = .Top
          
        End With

    Next sShapes

End Sub

Sub InsertRow()
Dim i As Long, rCell As Range
    For Each rCell In Selection
        If rCell <> "" Then
            If rCell.Offset(1, 0) <> rCell Then rCell.Offset(1, 0).EntireRow.Insert
        End If
    Next
End Sub