PDA

View Full Version : [SOLVED] Delete shapes before replacing



VISHAL120
08-21-2011, 10:01 PM
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
08-22-2011, 12:01 AM
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
08-22-2011, 01:33 AM
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
08-22-2011, 01:40 AM
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
08-22-2011, 01:43 AM
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
08-22-2011, 01:46 AM
Does for me. You haven't plugged my code into the spreadsheet.

Bob Phillips
08-22-2011, 02:02 AM
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
08-23-2011, 01:51 AM
Hi Xld,

Thanks a lot sir. its working well now.