Option
Explicit
Sub
RFB_Link()
Dim
rfbsheet
As
String
Dim
shapename
As
String
Dim
ActiveShape
As
shape
Dim
UserSelection
As
Variant
rfbsheet = ActiveSheet.Name
Set
UserSelection = ActiveWindow.Selection
On
Error
GoTo
NoShapeSelected
Set
ActiveShape = ActiveSheet.Shapes(UserSelection.Name)
shapename = ActiveShape.Name
Range(ActiveShape.TopLeftCell, ActiveShape.BottomRightCell).Copy
On
Error
Resume
Next
Sheets(
"Input data"
).
Select
ActiveCell.Value = rfbsheet &
"_"
& shapename
ActiveCell.Offset(0, -1).
Select
ActiveSheet.Pictures.Paste(link:=
False
).
Select
Selection.TopLeftCell.EntireRow.RowHeight = Selection.Height
Exit
Sub
NoShapeSelected:
MsgBox
"Please select a shape"
End
Sub