Excel VBA error 1004 when trying to delete buttons

2019-07-17 11:46发布

I'm having issues with deleting a range of cells that contains ActiveX command buttons in it, as the code below will throw an error 1004 "Application-defined or object-defined error" on the intersect part when debugging.

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

The sheet is not locked, and I made sure that all cells within the ranges are not locked as well. No merged cells too. I've tried other combinations of codes, but it still results in that error 1004. The code is in a module.

Strange thing is, if I add a code to ignore the error, it deletes the buttons without issues. However, a strange issue popped up, wherein the dropdown box from data validations fail to show up after deleting the buttons. The only way for it to show up is to save the workbook. Deleting the buttons after saving causes the disappearance of the dropdown again.

Any solutions to this?

EDIT: It looks like I'm experiencing some sort of "Phantom drop down" object with Type 8 based on VBasic2008's code. I've created a new sheet and tried to copy some of the old ones, then it persisted again. Further experimentation shows that it's coming from my Data Validation cells. Yet strangely enough, removing the data validation doesn't remove the drop down object. Clearing the entire sheet causes the object to still persist. I had to delete the sheet to get rid of it..

Is Data Validation being considered a Form Control? It shouldn't be.. right?

EDIT: How I generate my buttons

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

标签: excel vba button
1条回答
做自己的国王
2楼-- · 2019-07-17 12:45

Shapes

In VBE's object browser search for msoShapeType and you will notice that there are several shape types. In your case probably:

msoFormControl (8) - Drop downs
msoOLEControlObject (12) - Buttons and stuff.

Anyway try this code first to determine what you want to delete.

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

The following code deletes all msoOLEControlObject typed shapes on the ActiveSheet (Which I am assuming you want to delete):

Sub ShapesDelete()

  Dim shshape As Shape

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

End Sub

Finally your code:

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

I still haven't figured out the reason behind the error, but it is handled and all the buttons get deleted.

New Version:

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

No need for error handling since the WRONG Intercept line was causing the error.

查看更多
登录 后发表回答