The following modifications seems to work.
You can also remove a macro from a shape by changing
its OnAction property to a vbNullString.
It is not a good idea to use "name" as a variable...
--
Jim Cone
San Francisco, USA
http://www.realezsites.com/bus/primitivesoftware
(color sort, compare, unique, thesaurus and other add-ins)

Sub Macro_R1()
On Error GoTo Badentry
ActiveSheet.Unprotect
Dim shp As Shape
Dim sName As String

Dim msg As String
Dim ans As Long

sName = ActiveSheet.Shapes(Application.Caller).Name
Set shp = ActiveSheet.Shapes(sName)
shp.Copy
shp.TopLeftCell.Offset(0, 4).PasteSpecial
'Selection.ShapeRange.ScaleWidth 2.5, msoFalse, msoScaleFromTopLeft
'Selection.ShapeRange.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
Exit Sub

Badentry:
msg = "An error has occurred."
msg = msg + vbNewLine + vbNewLine
msg = msg + "Click on the name of an item in the menu, and then on the grey key."
msg = msg + vbNewLine + vbNewLine
msg = msg + "If you still get an error, e-mail P&D Technical Support Team"
ans = MsgBox(msg, vbExclamation, "Menu Problem")
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
End Sub
'------------


"Igby"
wrote in message
Hello.
I have a macro which is used in a sheet used to draw diagrams. The user
clicks on the shape which is then copied, enlarged and pasted a few cells to
the right.
The problem I am having is that the macro is still assigned to the pasted
shape, so when a user clicks on this shape, to move or resize it, the macro
runs again. So they end up with shapes all over the place.
Can anyone tell me how to remove the macro from the pasted shape?
Here is the macro...

Sub Macro1()
ActiveSheet.Unprotect
Dim shp As Shape
Dim name As String
'Change Rectangle 22 to actual name of shape
name = ActiveSheet.Shapes(Application.Caller).name
On Error GoTo Badentry
'Selects the shape using the name of the active shape
Set shp = ActiveSheet.Shapes(name)
shp.Select
'Change Range to wherever keeping counter
Selection.Copy
'Change Range to wherever pasting shape
ActiveCell.Offset(0, 4).Select
ActiveSheet.Paste
Selection.ShapeRange.ScaleWidth 2.5, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 2.5, msoFalse, msoScaleFromTopLeft
ActiveSheet.Protect DrawingObjects:=False, Contents:=True,
Scenarios:=True
Exit Sub

Badentry:
msg = "An error has occurred."
msg = msg + vbNewLine + vbNewLine
msg = msg + "Click on the name of an item in the menu, and then on the grey key."
msg = msg + vbNewLine + vbNewLine
msg = msg + "If you still get an error, e-mail P&D Technical Support Team"
Ans = MsgBox(msg, vbExclamation, "Menu Problem")
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:=True
End Sub