尝试从一系列单元格中删除按钮时 Excel VBA 错误 1004

Question

我在删除一系列包含 ActiveX 命令按钮的单元格时遇到问题，因为下面的代码在调试时会在相交部分引发错误 1004“应用程序定义或对象定义错误”。

Sub DeleteShapes() 
    Dim rng As Range
    Dim sh As Shape
    Set rng = Range("I7:K61")

    With Sheets("ADB")
        For Each sh In .Shapes    
            If Not Intersect(sh.TopLeftCell, .Range(rng)) Is Nothing Then
                sh.Delete
            End If
        Next
    End With
End Sub

工作表未锁定，我确保范围内的所有单元格也未锁定。也没有合并的单元格。我尝试了其他代码组合，但仍然导致错误 1004。代码在模块中。

奇怪的是，如果我添加一个代码来忽略错误，它会毫无问题地删除按钮。但是，出现了一个奇怪的问题，其中数据验证的下拉框在删除按钮后无法显示。它显示的唯一方法是保存工作簿。保存后删除按钮会导致下拉菜单再次消失。

有什么解决办法吗？

编辑:看起来我正在经历某种基于 VBasic2008 代码的类型为 8 的“幻影下拉”对象。我创建了一个新工作表并尝试复制一些旧工作表，然后它再次存在。
进一步的实验表明它来自我的数据验证单元格。然而奇怪的是，删除数据验证并不会删除下拉对象。清除整个工作表会导致对象仍然存在。我不得不删除工作表以摆脱它..

数据验证是否被视为表单控件？不应该……对吧？

编辑:我如何生成我的按钮

Public Sub GenerateButtons()
 Dim i As Long
 Dim shp As Object
 Dim ILeft As Double
 Dim dblTop As Double
 Dim dblWidth As Double
 Dim dblHeight As Double
 Dim lrow As Long

 lrow = Cells(Rows.count, 1).End(xlUp).Row

 With Sheets("ADB")
     ILeft = .Columns("I:I").Left      
     dblWidth = .Columns("I:I").Width    
     For i = 7 To lrow                      
         dblHeight = .Rows(i).Height     
         dblTop = .Rows(i).Top         
         Set shp = .Buttons.Add(ILeft, dblTop, dblWidth, dblHeight)
         shp.OnAction = "Copy1st"
         shp.Characters.Text = "Copy " & .Cells(i, 6).Value
     Next i
 End With

 End Sub

Answer 1

形状

在 VBE 的对象浏览器中搜索 msoShapeType 你会注意到
有几种形状类型。在你的情况下可能:

msoFormControl (8) - 下拉菜单
msoOLEControlObject (12) - 按钮和东西。

无论如何，首先尝试此代码以确定您要删除的内容。

Sub ShapeTypes()

  Dim shshape As Shape

  Const c1 = " , "
  Const r1 = vbCr
  Dim str1 As String

  str1 = "Shape Types in ActiveSheet"
  For Each shshape In ActiveSheet.Shapes
    str1 = str1 & r1 & Space(1) & shshape.Name & c1 & shshape.Type
  Next
  Debug.Print str1

End Sub

以下代码删除 ActiveSheet 上的所有 msoOLEControlObject 类型的形状(我假设您要删除):

Sub ShapesDelete()

  Dim shshape As Shape

  For Each shshape In ActiveSheet.Shapes
    If shshape.Type = 12 Then
      shshape.Delete
    End If
  Next

End Sub

最后你的代码:

Sub DeleteShapes()

    Const cStrRange As String = "I7:K61"
    Const cStrSheet As String = "ADB"

    Dim sh As Shape

    With Sheets(cStrSheet)
        For Each sh In .Shapes
            If sh.Type = 12 Then 'or msoOLEControlObject
                On Error Resume Next
                If Intersect(sh.TopLeftCell, .Range(cStrRange)) Then
                    If Not Err Then
                        sh.Delete
                    End If
                End If
            End If
        Next
    End With

End Sub

我仍然没有弄清楚错误背后的原因，但它已被处理并且所有按钮都被删除。

新版本:

Sub DeleteShapes()

    Const cStrRange As String = "I7:K61"
    Const cStrSheet As String = "ADB"

    Dim sh As Shape

    With Sheets(cStrSheet)
        For Each sh In .Shapes
            If sh.Type = 8 Then 'or msoFormControl
                On Error Resume Next
                If Not Intersect(sh.TopLeftCell, .Range(cStrRange)) Is Nothing Then
                    If Left(sh.Name,4) = "Butt" then  
                        sh.Delete
                    End If
                End If
            End If
        Next
    End With

End Sub

从 开始就不需要错误处理了错误 拦截线导致错误。