Add and delete pictures and shapes
 

I have a worksheet that I have validation/list values in. When the
operator pulls down to one of the choices "Thumbs Up", "Caution", or
"Bomb!" On workbook change event to copy a picture and put it in a
certain cell. There is also the option of blank. when the operator
hits this I would like the selection to clear of pictures. Here is my
event change code. the Test in the last Elseif statment refers to the
macro that is under this one. If I run Test by itself it works for
the selection, but if I run it through the change event it errors out
on the set Rng line. any ideas or thoughts on how to do this better?

Thanks,
Jay

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
Application.ScreenUpdating = False
If Target.Column = 7 Then
If Target.Value = "Thumbs Up" Then
Sheet1.Shapes("Picture 5").Copy
Target.Offset(0, -1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -6
ElseIf Target.Value = "Caution" Then
Sheet1.Shapes("Picture 3").Copy
Target.Offset(0, -1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementTop -35
Selection.ShapeRange.IncrementLeft -15
ElseIf Target.Value = "BOMB!" Then
Target.Offset(0, -1).Select
Sheet1.Shapes("TheBomb").Copy
ActiveSheet.Paste
Selection.Name = "TheBomb"
Selection.ShapeRange.IncrementLeft -8
ElseIf Target.Value = "" Then
Selection.Offset(0, -1).Select
Test
End If
Else
Exit Sub
End If
Application.ScreenUpdating = True
End Sub


Sub Test()
Const cDeleteOnTouch As Boolean = True
Dim rng As Range, shp As Shape, rngSelect As Range, blnDelete As
Boolean

Set rngSelect = Selection
MsgBox (rngSelect.Address)
For Each shp In Sheet1.Shapes
blnDelete = False
Set rng = Intersect(Range(shp.TopLeftCell,
shp.BottomRightCell), rngSelect)
If cDeleteOnTouch Then
If Not rng Is Nothing Then blnDelete = True
Else
If Not rng Is Nothing Then
If rng.Address = Range(shp.TopLeftCell,
shp.BottomRightCell).Address Then blnDelete = True
End If
End If

If blnDelete Then
MsgBox "delete " & shp.Name
shp.Delete
End If
Next
End Sub

Add and delete pictures and shapes
 

Contextures.com has sample files for this on
http://www.contextures.com/excelfiles.html#Charts

Peter

"jlclyde" wrote:

I have a worksheet that I have validation/list values in. When the
operator pulls down to one of the choices "Thumbs Up", "Caution", or
"Bomb!" On workbook change event to copy a picture and put it in a
certain cell. There is also the option of blank. when the operator
hits this I would like the selection to clear of pictures. Here is my
event change code. the Test in the last Elseif statment refers to the
macro that is under this one. If I run Test by itself it works for
the selection, but if I run it through the change event it errors out
on the set Rng line. any ideas or thoughts on how to do this better?

Thanks,
Jay

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
Application.ScreenUpdating = False
If Target.Column = 7 Then
If Target.Value = "Thumbs Up" Then
Sheet1.Shapes("Picture 5").Copy
Target.Offset(0, -1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementLeft -6
ElseIf Target.Value = "Caution" Then
Sheet1.Shapes("Picture 3").Copy
Target.Offset(0, -1).Select
ActiveSheet.Paste
Selection.ShapeRange.IncrementTop -35
Selection.ShapeRange.IncrementLeft -15
ElseIf Target.Value = "BOMB!" Then
Target.Offset(0, -1).Select
Sheet1.Shapes("TheBomb").Copy
ActiveSheet.Paste
Selection.Name = "TheBomb"
Selection.ShapeRange.IncrementLeft -8
ElseIf Target.Value = "" Then
Selection.Offset(0, -1).Select
Test
End If
Else
Exit Sub
End If
Application.ScreenUpdating = True
End Sub


Sub Test()
Const cDeleteOnTouch As Boolean = True
Dim rng As Range, shp As Shape, rngSelect As Range, blnDelete As
Boolean

Set rngSelect = Selection
MsgBox (rngSelect.Address)
For Each shp In Sheet1.Shapes
blnDelete = False
Set rng = Intersect(Range(shp.TopLeftCell,
shp.BottomRightCell), rngSelect)
If cDeleteOnTouch Then
If Not rng Is Nothing Then blnDelete = True
Else
If Not rng Is Nothing Then
If rng.Address = Range(shp.TopLeftCell,
shp.BottomRightCell).Address Then blnDelete = True
End If
End If

If blnDelete Then
MsgBox "delete " & shp.Name
shp.Delete
End If
Next
End Sub

Add and delete pictures and shapes
 

On Oct 22, 8:01*am, Billy Liddel
wrote:
Contextures.com has sample files for this onhttp://www.contextures.com/excelfiles.html#Charts

Peter



"jlclyde" wrote:
I have a worksheet that I have validation/list values in. *When the
operator pulls down to one of the choices "Thumbs Up", "Caution", or
"Bomb!" On workbook change event to copy a picture and put it in a
certain cell. *There is also the option of blank. *when the operator
hits this I would like the selection to clear of pictures. *Here is my
event change code. *the Test in the last Elseif statment refers to the
macro that is under this one. *If I run Test by itself it works for
the selection, but if I run it through the change event it errors out
on the set Rng line. *any ideas or thoughts on how to do this better?

Thanks,
Jay

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As
Range)
* * Application.ScreenUpdating = False
* * If Target.Column = 7 Then
* * * * If Target.Value = "Thumbs Up" Then
* * * * * * Sheet1.Shapes("Picture 5").Copy
* * * * * * Target.Offset(0, -1).Select
* * * * * * ActiveSheet.Paste
* * * * * * Selection.ShapeRange.IncrementLeft -6
* * * * ElseIf Target.Value = "Caution" Then
* * * * * * Sheet1.Shapes("Picture 3").Copy
* * * * * * Target.Offset(0, -1).Select
* * * * * * ActiveSheet.Paste
* * * * * * Selection.ShapeRange.IncrementTop -35
* * * * * * Selection.ShapeRange.IncrementLeft -15
* * * * ElseIf Target.Value = "BOMB!" Then
* * * * * * Target.Offset(0, -1).Select
* * * * * * Sheet1.Shapes("TheBomb").Copy
* * * * * * ActiveSheet.Paste
* * * * * * Selection.Name = "TheBomb"
* * * * * * Selection.ShapeRange.IncrementLeft -8
* * * * ElseIf Target.Value = "" Then
* * * * * * Selection.Offset(0, -1).Select
* * * * * * Test
* * * * End If
* * Else
* * * * Exit Sub
* * End If
Application.ScreenUpdating = True
End Sub

Sub Test()
* * Const cDeleteOnTouch As Boolean = True
* * Dim rng As Range, shp As Shape, rngSelect As Range, blnDelete As
Boolean

* * Set rngSelect = Selection
MsgBox (rngSelect.Address)
* * For Each shp In Sheet1.Shapes
* * * * blnDelete = False
* * * * Set rng = Intersect(Range(shp.TopLeftCell,
shp.BottomRightCell), rngSelect)
* * * * If cDeleteOnTouch Then
* * * * * * If Not rng Is Nothing Then blnDelete = True
* * * * Else
* * * * * * If Not rng Is Nothing Then
* * * * * * * * If rng.Address = Range(shp.TopLeftCell,
shp.BottomRightCell).Address Then blnDelete = True
* * * * * * End If
* * * * End If

* * * * If blnDelete Then
* * * * * * MsgBox "delete " & shp.Name
* * * * * * shp.Delete
* * * * End If
* * Next
End Sub- Hide quoted text -

- Show quoted text -

Billy,
I had to change it around to work for my application but this works
great. It has reduced the file size and any need for code.
Thanks,
Jay