Option Explicit
Sub MakePictureOfUserRange()
Dim wsData As Worksheet
' Range object that points to the cells selected by the user.
Dim rUserSelection As Range
' Range object points to the cell where the picture is placed.
Dim rOutput As Range
Dim sPictureName As String
Dim bProtectStatus As Boolean
Dim sPassword As String
Set wsData = ThisWorkbook.Worksheets("Sheet1") '<= specify the sheet name here.
' Protection password if one is used.
sPassword = ""
On Error Resume Next
Set rUserSelection = Selection
On Error GoTo 0
' If the selection is not a range then tell user and exit sub
If rUserSelection Is Nothing _
Then
MsgBox "Please select cells to make a picture of.", vbExclamation, "Making the picture."
Exit Sub
End If
' If the selection is one cell or empty then tell user and exit sub
If rUserSelection.Cells.Count = 1 Or rUserSelection.Cells(1).Value = "" _
Then
MsgBox "Please select cells to make a picture of.", vbExclamation, "Making the picture."
Exit Sub
End If
' Set the range where the picture will be placed.
'Set rOutput = wsData.Range("E2") '<= use this to specif a specific cell
' Set output range = two cells over from the data selected.
Set rOutput = rUserSelection.Cells(1).Offset(0, 2)
' Specify the name of the picture.
sPictureName = "User Selection"
' Determine if the worksheet is protected. Save the status.
bProtectStatus = wsData.ProtectContents
' Unprotect the worksheet.
'wsData.Unprotect '<= if there is no password for protection
wsData.Unprotect Password:=sPassword
' Make the picture.
Call DoCamera(rUserSelection, rOutput, sPictureName)
' Leave user next to where the picture was placed.
rOutput.Offset(0, -1).Activate
' If the worksheet is protected then reprotect it.
If bProtectStatus Then wsData.Protect Password:=sPassword, Userinterfaceonly:=True
End Sub
Sub DoCamera(prUserSelection As Range, prOutput As Range, psPictureName As String)
Dim wsPicture As Worksheet
Set wsPicture = prUserSelection.Parent
' Delete the picture if it already exists.
On Error Resume Next
wsPicture.Shapes.Range(Array(psPictureName)).Delete
On Error GoTo 0
' Copy user selection range.
prUserSelection.CopyPicture
' put the picture into the output range (cell).
prOutput.PasteSpecial
' Tell picture what range it is showing by setting its
' formula to the address of the user selection range.
Selection.Formula = prUserSelection.Address
' Give name to the picture.
Selection.Name = psPictureName
' Picture is not locked.
Selection.Locked = msoFalse
End Sub