如何使用 VBA 删除工作表中的特定形状？

Question

I have a sheet with a lot of shapes. I need to delete only the shapes which are located after row 15, and shapes which have Resize and Clear All written on it. The shapes are a rectangle: rounded corners keeping text and having a macro assigned

How you can see in the image, I will have pictures (screenshots) and it cant be deleted, the thing I am trying to delete is the blue "button".

Answer 1

First, your If-statement is wrong, see BigBen's comment:

If oShape.Name = "Resize" Or oShape.Name = "Clear All" Then

However, this will check the name of the shapes, not their text. To get the text of the shape, you can use oShape.TextFrame2.TextRange.Text . However, you can face two small issues with that:

(1) There are shapes without text, eg Pictures. This can be checked with oShape.TextFrame2.HasText

(2) It may be the case that the text has a newline at the end or that it has contains leading or trailing spaces, so I would suggest you write the content into a variable and use the Instr -function:

if oShape.TextFrame2.HasText Then
    dim shapeText as string
    shapeText = oShape.TextFrame2.TextRange.Text
    if InStr(shapeText, "Resize") > 0 or InStr(shapeText, "Clear All") > 0 then
       oShape.Delete
    End If
End If

Answer 2

Try the next code, please (now it deletes only rounded corners rectangles according to your conditions):

Sub testDeleteInsertedShapes()
Dim ws As Worksheet, sh As Shape, shR As ShapeRange, rng As Range
  Set ws = ActiveSheet
  Set rng = ws.Range(ws.Range("A1"), ws.Cells(15, Columns.count))

  Application.EnableEvents = False
  For Each sh In ws.Shapes
    If sh.Type = 1 Then 'rounded rectangles
        If Not Intersect(sh.TopLeftCell, rng) Is Nothing Then
            If sh.TextFrame2.TextRange.text = "Resize" Or _
                 sh.TextFrame2.TextRange.text = "Clear All" Then
                sh.Delete
            End If
        Else
            sh.Delete
        End If
    End If
  Next
  Application.EnableEvents = True
End Sub

And a code version deleting all shapes type (excepting pictures), I start working before you answered my question:

Sub deleteShapesAllTypes()
  Dim ws As Worksheet, sh As Shape, shR As ShapeRange, rng As Range
  Set ws = ActiveSheet
  Set rng = ws.Range(ws.Range("A1"), ws.Cells(15, Columns.count))
  Debug.Print rng.Address
  For Each sh In ws.Shapes
    If sh.Type = 8 Then
        If Not Intersect(sh.TopLeftCell, rng) Is Nothing Then
            If sh.OLEFormat.Object.text = "Resize" Or _
                   sh.OLEFormat.Object.text = "Clear All" Then
                sh.Delete
            End If
        Else
            sh.Delete
        End If
    ElseIf sh.Type = 12 Then
        If Not Intersect(sh.TopLeftCell, rng) Is Nothing Then
            If sh.OLEFormat.Object.Object.Caption = "Resize" Or _
                   sh.OLEFormat.Object.Object.Caption = "Clear All" Then
                sh.Delete
            End If
        Else
            sh.Delete
        End If
    Else
        If sh.Type <> 13 Then
            If Not Intersect(sh.TopLeftCell, rng) Is Nothing Then
                If sh.TextFrame2.TextRange.text = "Resize" Or _
                     sh.TextFrame2.TextRange.text = "Clear All" Then
                    sh.Delete
                End If
            Else
                sh.Delete
            End If
        End If
    End If
  Next
End Sub

Answer 3

Try:

Sub shapeKiller()
    Dim i As Long, N As Long, nm As String, rw As Long
    Dim sh As Shape
    N = ActiveSheet.Shapes.Count

    For i = N To 1 Step -1
        Set sh = ActiveSheet.Shapes(i)
        nm = sh.Name
        rw = sh.TopLeftCell.Row
        If nm = "Resize" Or nm = "Clear All" Or rw > 15 Then
            sh.Delete
        End If
    Next i
End Sub