Deleting a shape with its name set as a variable

[niall91]

HI Guys
Could someone please help me with this problem.

This macro inserts a button and names it corresponding to the cell row the value is entered . My issue is when the value is deleted from that row i want the button to be deleted also.

When i change this macro to hide and unhide the button (that has been created already before the macro runs) rather than create a new button inside the macro it works perfect. The problem seems to be creating the button inside the macro.

Thanks


Private Sub Worksheet_Change(ByVal Target As Range)
d1 = "D-01"
d2 = "D-02"
Dim u As String
u = Cells(Target.Row, 2)

If Not Intersect(Target, Range("H47:H96")) Is Nothing Then
If UCase(Cells(Target.Row, 8)) = d1 Or _
UCase(Cells(Target.Row, 8)) = d2 _
Then _
'ActiveSheet.Shapes.Range(Array(u)).Visible = msoTrue
ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 390, _
662.4, 45, 14.4).Select
Selection.ShapeRange.ThreeD.BevelTopType = msoBevelNone
Selection.ShapeRange.Shadow.Visible = msoFalse
Selection.ShapeRange.Name = u

With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = -0.25
.Transparency = 0.2900000215
.Solid
End With

Selection.ShapeRange.TextFrame2.TextRange.Font.size = 10
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Modify"
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).Font
.NameComplexScript = "+mn-cs"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.size = 10
.Name = "+mn-lt"
End With
Range("A1").Select

End If
End If

If Not Intersect(Target, Range("H47:H96")) Is Nothing Then
If UCase(Cells(Target.Row, 8)) = "" _
Then _
ActiveSheet.Shapes.Range(Array(u)).Select
Selection.Delete

End If
End If
Stop

End Sub

 

[Misca]

Looks like your code is a bit too clever for itself (or maybe it's just me):

1) The Target value has to be d1 or d2 or it won't create the button.​

2) At the same time it only deletes the button if the same cell value is empty.​

 

[niall91]

Looks like your code is a bit too clever for itself (or maybe it's just me):

1) The Target value has to be d1 or d2 or it won't create the button.​

2) At the same time it only deletes the button if the same cell value is empty.​

Yes this is true. i want the button to be deleted if the user deletes the target value. Any ideas?

 

[NoSparks]

works for me

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim u As String, d1 As String, d2 As String

d1 = "D-01"
d2 = "D-02"
u = Cells(Target.Row, 2)

If Not Intersect(Target, Range("H47:H96")) Is Nothing Then
    If UCase(Target) = d1 Or UCase(Target) = d2 Then
        ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 390, 662.4, 45, 14.4).Select
        Selection.ShapeRange.ThreeD.BevelTopType = msoBevelNone
        Selection.ShapeRange.Shadow.Visible = msoFalse
        Selection.ShapeRange.Name = u
    
        With Selection.ShapeRange.Fill
            .Visible = msoTrue
            .ForeColor.ObjectThemeColor = msoThemeColorAccent1
            .ForeColor.TintAndShade = 0
            .ForeColor.Brightness = -0.25
            .Transparency = 0.2900000215
            .Solid
        End With

        Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 10
        Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Modify"
        
        With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 6).Font
            .NameComplexScript = "+mn-cs"
            .NameFarEast = "+mn-ea"
            .Fill.Visible = msoTrue
            .Fill.ForeColor.ObjectThemeColor = msoThemeColorLight1
            .Fill.ForeColor.TintAndShade = 0
            .Fill.ForeColor.Brightness = 0
            .Fill.Transparency = 0
            .Fill.Solid
            .Size = 10
            .Name = "+mn-lt"
        End With
        
        Range("A" & Target.Row).Select    'so can still see area of interest

    End If
End If

If Not Intersect(Target, Range("H47:H96")) Is Nothing Then
    If Target = "" Then
        On Error Resume Next    'in case no such shape
        ActiveSheet.Shapes.Range(Array(u)).Select
        Selection.Delete
        On Error GoTo 0         're-enable error notification
    End If
End If

'Stop

End Sub

 

[niall91]

That works great thanks you

Maybe you can help me with another question?

ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, 390, 662.4, 45, 14.4).Select
These x,y points on the sheet. Is there code to move shapes to specific locations using these points.

Thanks again

 

[NoSparks]

Ah-yes, I thought it strange where the shape was being placed.

In the VBA editing window, put your cursor within the word AddShape and hit the F1 key to bring up the built-in help for that instruction.
You'll see the first two numbers position the shape relative to the upper-left corner of the document and the other two set the shapes size.

So if you wanted to locate the shape at a particular cell location you could use variables as the left and top of that particular cell.
For example to position the shape on the right next to the target:

If Not Intersect(Target, Range("H47:H96")) Is Nothing Then
    If UCase(Target) = d1 Or UCase(Target) = d2 Then
        
        With Target.Offset(, 1).Cells
            L = .Left
            T = .Top
        End With
        
        ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, L, T, 45, 14.4).Select

Hope that helps.

 

[niall91]

Thanks this is great. Im only learning VBA so simple things like this trip me up all the time. ?