Auto delete button located on top of specific cell

[Biker57]

Sir, Ma'am,
I have a piece of code that locks a cell down after the user selects items from the drop-down list associated with the cell. There is a button on the adjacent cell to the right that needs to be automatically deleted when several items of the drop-down list are chosen. The drop down list choices are " ", "As required", "Monthly", "Quarterly", and "Annual". Selecting ". When Blank, Monthly, Quarterly and Annual are chosen the button on cell to right needs to be removed or deleted. The code below locks down the cell but does not delete the button as required.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyRange As Range
    Dim bu As Button
    
    Set MyRange = Intersect(Range("C5:C133"), Target)
    If Not MyRange Is Nothing Then
        ActiveSheet.Unprotect Password:="CLS"
        MyRange.Locked = True
        If MyRange = "" Or MyRange = "Monthly" Or MyRange = "Quarterly" Or MyRange = "Annual" Then
            For Each bu In ActiveSheet.Buttons
                If bu.TopLeftCell.Address = ActiveCell.Offset(0, 1).Address Then bu.Delete
            Next
        End If
        ActiveSheet.Protect Password:="CLS"
    End If
End Sub

[/End Code]

Thank you in advance for any help
Biker57

 

[BiocideJ]

At first blush, I don't see any specific reason the code above wouldn't work.

Are you sure the objects are actual buttons and not simply shapes?

Perhaps try replacing .Buttons with .Shapes

e.g. For Each bu in ActiveSheet.Shapes

 

[Biker57]

Mr. BiocideJ,
Thank you, you were correct the buttons are not buttons they are shapes. It revealed a second issue though. The button is removed automatically but not before a Run-time error '1004': 'Application-defined or object-defined error' which is on the following line,

If bu.TopLeftCell.Address = ActiveCell.Offset(0, 1).Address Then bu.Delete.

In debug the line is highlighted yellow up to the word Then. When I hit end on the error window the button disappears and the target cell is locked down as hoped for.

Regards,
Biker57

 

[BiocideJ]

I recreated your scenario and it 'kind of' works the way I would expect. I wasn't using drop-downs and when I press enter to confirm the cell value, it was changing my ActiveCell location and was then deleting a the shape in a row below where I expected.

I suspect with drop-downs the ActiveCell *should* always be the same as the MyRange cell, but I think the following code should work (at least it does for me) the way you are requesting.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim MyRange As Range
    Dim bu As Shape

    Set MyRange = Intersect(Range("C5:C133"), Target)
    If Not MyRange Is Nothing Then
        ActiveSheet.Unprotect Password:="CLS"
        MyRange.Locked = True
        If MyRange = "" Or MyRange = "Monthly" Or MyRange = "Quarterly" Or MyRange = "Annual" Then
            For Each bu In ActiveSheet.Shapes
                If bu.TopLeftCell.Address = MyRange.Offset(0, 1).Address Then bu.Delete
            Next
        End If
        ActiveSheet.Protect Password:="CLS"
    End If
End Sub

I've highlighted my changes with red text so you can see what I've changed.