Sub delShapes()
For Each shp In ActiveSheet.Shapes
   shp.Delete
Next
End Sub

Sub DeleteShapes() : ActiveSheet.DrawingObjects.Delete:End Sub

Sub DelExtraLinesAndRects()
'ZVI:2016-09-05 http://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&TID=81585&MID=681866
'Удаление дубликатов стрелок и прямоугольников на активном листе
'Удаляются также прямоугольники с нулевой высотой или шириной
  
  Dim Col As Collection
  Dim i As Long, k As String, lin As Line, rec As Rectangle

  On Error Resume Next
  
  ' Удаление дубликатов стрелок
  Application.StatusBar = "Удаление дубликатов стрелок..."
  Set Col = New Collection
  For Each lin In ActiveSheet.Lines
    With lin
      k = .Left & .Top & .Width & .Height
      Col.Add vbNullString, k
      If Err Then
        i = i + 1
        .Delete
        Err.Clear
        If i Mod 100 = 0 Then Application.StatusBar = "Удалено дубликатов стрелок: " & i
      End If
    End With
  Next
  Application.StatusBar = False
  If MsgBox("Удалено дубликатов стрелок: " & i _
            & vbLf & "Для удаления дубликатов прямоугольников нажмите OK", _
            vbOKCancel) <> vbOK Then Exit Sub

  'Удаление дубликатов и невидимых прямоугольников
  Application.StatusBar = "Удаление дубликатов и невидимых прямоугольников..."
  i = 0
  Set Col = New Collection
  For Each rec In ActiveSheet.Rectangles
    With rec
      k = .Left & .Top & .Width & .Height
      If .Width = 0 Or .Height = 0 Then
        Err.Raise 1
      Else
        Col.Add vbNullString, k
      End If
      If Err Then
        i = i + 1
        .Delete
        Err.Clear
        If i Mod 100 = 0 Then Application.StatusBar = "Удалено дубликатов и невидимых прямоугольников: " & i
      End If
    End With
  Next
  Application.StatusBar = False
  MsgBox "Удалено дубликатов и невидимых прямоугольников: " & i, vbOK
  
End Sub