[SOLVED:] Delete shapes before replacing

1 Attachment(s)

Delete shapes before replacing

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. :

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

hi.

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

Code:

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

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

Code:

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

1 Attachment(s)

delete shapes before replacing

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.

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.

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

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.

Code:

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

Hi Xld,

Thanks a lot sir. its working well now.