Sub Макрос1()
Dim lH As Long, lW As Long
Dim strShNa As String, strFiNa As String
    strFiNa = "C:\new.jpg"
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap  'могут быть разные параметры качества
    lH = Selection.Height
    lW = Selection.Width
    Charts.Add
    ActiveChart.SetSourceData Source:=Sheets("Лист1").Range("A1") 'A1 - пустая ячейка
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Лист1"
    strShNa = ActiveChart.Name
    strShNa = Trim(Replace(strShNa, "Лист1", vbNullString))
    ActiveSheet.Shapes(strShNa).Height = lH + 8  'при вставке картинки в диаграмму остаётся рамка
    ActiveSheet.Shapes(strShNa).Width = lW + 8   'по этому увеличиваем её на двойную толщину
        DoEvents
    ActiveChart.Paste
    ActiveChart.Export Filename:=strFiNa, FilterName:="jpg"
    ActiveSheet.Shapes(strShNa).Delete
End Sub