Delete shapes before replacing

[VISHAL120]

I have actually this program which is working well when i searches for the shapes to be place on the cell.

The problem am having actually is i have not been able to program the deletion of the shapes before placing another one on the cell.

the user will select a day and the shape need to pe place on the defined cell.
and for other day the first shape shall be removed and the concern shape need to place and this goes on like this.

the user can select any day.

and also is there a posibility to place the concern code on the worksheet selection change event.

thanks in advance for the kind help.

please find attached the file for better idea and also copy of the code. :

Sub MY_data()
days_selection = Range("Day_Selection")
Select Case days_selection
        Case 1
                ActiveSheet.Shapes("Quad Arrow 1").Select
                Selection.Copy
                Range("days_Cells").Select
                ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
                DisplayAsIcon:=False
        Case 2
                ActiveSheet.Shapes("Bent-Up Arrow 2").Select
                Selection.Copy
                Range("days_Cells").Select
                ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
                DisplayAsIcon:=False
        Case 3
                ActiveSheet.Shapes("AutoShape 18").Select
                Selection.Copy
                Range("days_Cells").Select
                ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
                DisplayAsIcon:=False
                Case 4
                ActiveSheet.Shapes("Down Arrow 4").Select
                Selection.Copy
                Range("days_Cells").Select
                ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
                DisplayAsIcon:=False
                Case 5
                ActiveSheet.Shapes("12-Point Star 5").Select
                Selection.Copy
                Range("days_Cells").Select
                ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
                DisplayAsIcon:=False
                End Select
        End Sub

[mancubus]

hi.

copy the follwing code to Workseet("DATA") code module.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
Dim day_sel As Range
Set day_sel = Range("Day_Selection")
If Intersect(Target, day_sel) Is Nothing Then Exit Sub
On Error GoTo sel_day
For Each shp In Shapes
    If Not Intersect(shp.TopLeftCell, Range("F18")) Is Nothing Then shp.Delete
Next shp
sel_day:
Select Case day_sel
    Case 1
        ActiveSheet.Shapes("Quad Arrow 1").Select
        Selection.Copy
        Range("days_Cells").Select
        ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
        DisplayAsIcon:=False
    Case 2
        ActiveSheet.Shapes("Bent-Up Arrow 2").Select
        Selection.Copy
        Range("days_Cells").Select
        ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
        DisplayAsIcon:=False
    Case 3
        ActiveSheet.Shapes("AutoShape 18").Select
        Selection.Copy
        Range("days_Cells").Select
        ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
        DisplayAsIcon:=False
    Case 4
        ActiveSheet.Shapes("Down Arrow 4").Select
        Selection.Copy
        Range("days_Cells").Select
        ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
        DisplayAsIcon:=False
    Case 5
        ActiveSheet.Shapes("12-Point Star 5").Select
        Selection.Copy
        Range("days_Cells").Select
        ActiveSheet.PasteSpecial Format:="Picture (PNG)", Link:=False, _
        DisplayAsIcon:=False
End Select
End Sub

[Bob Phillips]

This code is a tad tidier, and also centres the shape in the cell

Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
Dim day_sel As Range
Set day_sel = Range("Day_Selection")
If Intersect(Target, day_sel.Offset(0, -1)) Is Nothing Then Exit Sub
On Error GoTo sel_day
For Each shp In Me.Shapes
    If Not Intersect(shp.TopLeftCell, Me.Range("F17:F18")) Is Nothing Then shp.Delete
    Next shp
    sel_day:
    With Me
        Select Case day_sel
            Case 1:     .Shapes("Quad Arrow 1").Copy
            Case 2:     .Shapes("Bent-Up Arrow 2").Copy
            Case 3:     .Shapes("AutoShape 18").Copy
            Case 4:     .Shapes("Down Arrow 4").Copy
            Case 5:     .Shapes("12-Point Star 5").Copy
        End Select
        .Range("days_Cells").Select
        .Paste
        Selection.Left = ActiveCell.Left + ActiveCell.Width / 2 - Selection.Width / 2
        Selection.Top = ActiveCell.Top + ActiveCell.Height / 2 - Selection.Height / 2
        .Range("days_Cells").Offset(0, -2).Select
    End With
End Sub

[VISHAL120]

Hi thanks for the quick reply . i have place the code as you advised but it do not delete the previous shapes see the attachement.

[VISHAL120]

Hi Xld,

thanks for the code but still it do not delete the previous shape on the F18.

can you please recheck.

jusd tested same.

[Bob Phillips]

Does for me. You haven't plugged my code into the spreadsheet.

[Bob Phillips]

I have just checked in Excel 2003, and see the problem shows there.

Here is another version, a bit more complex as I need to stop it deleting the DV arrow.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim shp As Shape
    Dim day_sel As Range
    Set day_sel = Range("Day_Selection")
    If Intersect(Target, day_sel.Offset(0, -1)) Is Nothing Then Exit Sub
    On Error GoTo sel_day
    For Each shp In Me.Shapes
    Call DeleteShape(shp)
    Next shp
    sel_day:
    With Me
        Select Case day_sel
            Case 1:     .Shapes("Quad Arrow 1").Copy
            Case 2:     .Shapes("Bent-Up Arrow 2").Copy
            Case 3:     .Shapes("AutoShape 18").Copy
            Case 4:     .Shapes("Down Arrow 4").Copy
            Case 5:     .Shapes("12-Point Star 5").Copy
        End Select
        .Range("days_Cells").Select
        .Paste
        Selection.Left = ActiveCell.Left + ActiveCell.Width / 2 - Selection.Width / 2
        Selection.Top = ActiveCell.Top + ActiveCell.Height / 2 - Selection.Height / 2
        .Range("days_Cells").Offset(0, -2).Select
    End With
Next shp
End Sub

Private Function DeleteShape(ByRef shp As Shape)
Dim cell As Range
On Error Resume Next
    Set cell = shp.TopLeftCell
    If cell Is Nothing Then
    If shp.Type = msoFormControl Then
        If shp.FormControlType = xlDropDown Then
            If cell.Address = "" Then
                fOK = False     'keep it
            End If
        End If
    End If
    ElseIf Intersect(cell, Me.Range("F11:F15")) Is Nothing Then
    shp.Delete
    End If
Set cell = Nothing
End Function

[VISHAL120]

Hi Xld,

Thanks a lot sir. its working well now.