Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet
    If TypeName(Selection) <> "Range" Then
        MsgBox "Âûäåëåííàÿ îáëàñòü íå ÿâëÿåòñÿ äèàïàçîíîì!", vbCritical, ""
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Selection
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = "SB"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".jpg", FilterName:="jpg"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

Private Sub Paste()
Range("A1").Select
ActiveSheet.Paste
 End Sub

Dim xStr As String
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim xShapeRg As ShapeRange
    On Error Resume Next
    If Not Application.Intersect(Target, Range("A1")) Is Nothing Then
        Me.CommandButton1.Caption = Target.Text
        Set xShapeRg = ActiveSheet.Shapes.Range(xStr)
        If xShapeRg Is Nothing Then Set xShapeRg = ActiveSheet.Shapes.Range("CommandButton1")
        Application.EnableEvents = False
        xShapeRg.Select
        Application.EnableEvents = True
        Selection.Name = Target.Text
    End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If (Not Intersect(Target, Range("A1")) Is Nothing) And Target.Text <> "" Then
        xStr = Target.Text
    End If
End Sub