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

Question

我有一个有很多形状的工作表。 我需要删除位于第15行之后的形状，以及写有 "调整大小 "和 "全部清除 "的形状。

你如何可以看到在图像中，我将有图片（截图），它不能被删除，我试图删除的东西是蓝色的 "按钮"。

Answer 1

请尝试下一段代码（现在它根据你的条件只删除圆角矩形）。

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

还有一个删除所有形状的代码版本(除了图片), 我在你回答我的问题之前就开始工作了:

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 2

首先，你的If -statement是错误的，参见BigBen的评论。

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

然而，这将检查形状的名称，而不是它们的文本。要获得形状的文本，你可以使用 oShape.TextFrame2.TextRange.Text. 但是，你可能会面临两个小问题。

(1)有一些形状没有文字，比如图片。这可以用 oShape.TextFrame2.HasText

(2) 可能是文本末尾有一个换行符，或者文本中包含了前导符或尾部的空格，所以我建议你把内容写进一个变量中，然后使用 Instr-功能。

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 3

功能：

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