Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet, sPath As String, sFileName As String, Rng As Range
    Dim startCell As String, endCell As String
    Dim width As Double, height As Double

    ' Get the Excel file path
    sPath = ThisWorkbook.Path & Application.PathSeparator

    ' Get the start and end cell addresses from the "Указатели" sheet
    With ThisWorkbook.Sheets("Указатели")
        startCell = .Range("A2").Value
        endCell = .Range("B2").Value
    End With

    ' Get the Excel file name without extension
    sFileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)

    ' Define the range based on the start and end cells
    With ThisWorkbook.Sheets("Данные")
        Set Rng = .Range(startCell & ":" & endCell)
    End With

    ' Calculate the width and height based on the range size
    width = (Rng.Columns.Count * 92.44) ' Adjust multiplier as needed
    height = (Rng.Rows.Count * 33.58) ' Adjust multiplier as needed

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set wsTmpSh = ThisWorkbook.Sheets.Add

    With wsTmpSh.ChartObjects.Add(0, 0, width:=width, height:=height).Chart
        .ChartArea.Border.LineStyle = 0
        .Parent.Select
        Rng.CopyPicture
        .Paste
        .Export fileName:=sPath & sFileName & ".jpg", FilterName:="jpg"
        .Parent.Delete
    End With

    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox "Картинка сохранена!" & vbNewLine & sPath & sFileName & ".jpg", vbInformation, "Конец"

End Sub

Sub Range_to_Picture()
    Dim sName As String, wsTmpSh As Worksheet, sPath As String, sFileName As String, Rng As Range
     
    sPath = "e:\2" 'путь для сохранения файла
    If Right(sPath, 1) <> Application.PathSeparator Then sPath = sPath & Application.PathSeparator
     
    'проверяем наличии папки для сохранения, если её нет, то создаём её
    If Dir(sPath, vbDirectory) = "" Then MkDir (sPath)
 
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets("Данные")
        Set Rng = .Range("B2:FO73") 'диапазон ячеек
        sFileName = .Range("A1") 'имя файла из ячейки А1
        Rng.CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        With wsTmpSh.ChartObjects.Add(0, 0, width:=15714, height:=2451).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export fileName:=sPath & sFileName & ".jpg", FilterName:="jpg"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Картинка сохранена!" & vbNewLine & sPath & sFileName & ".jpg", vbInformation, "Конец"
End Sub

Sub ОбъединенныйМакрос()

    Dim wsУказатели As Worksheet
    Dim wsДанные As Worksheet
    Dim wsВременный As Worksheet
    Dim начЯчейка As String
    Dim конЯчейка As String
    Dim rngКопировать As Range
    Dim рисунок As Picture
    Dim sName As String
    Dim wsTmpSh As Worksheet

    ' Установим ссылки на нужные листы
    Set wsУказатели = ThisWorkbook.Sheets("Указатели")
    Set wsДанные = ThisWorkbook.Sheets("Данные")

    ' Получим адреса начала и конца диапазона
    начЯчейка = wsУказатели.Range("A2").Value
    конЯчейка = wsУказатели.Range("B2").Value

    ' Определим диапазон на листе "Данные"
    Set rngКопировать = wsДанные.Range(начЯчейка & ":" & конЯчейка)

    ' Создадим временный лист
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("ВременныйЛист").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    Set wsВременный = ThisWorkbook.Sheets.Add
    wsВременный.Name = "ВременныйЛист"

  Dim i As Long
    Dim j As Long
    Dim начCol As Long, конCol As Long
    Dim начRow As Long, конRow As Long

    начCol = wsДанные.Range(начЯчейка).Column
    конCol = wsДанные.Range(конЯчейка).Column
    начRow = wsДанные.Range(начЯчейка).Row
    конRow = wsДанные.Range(конЯчейка).Row

    ' Копируем ширину столбцов
    For i = начCol To конCol
        wsВременный.Columns(i).ColumnWidth = wsДанные.Columns(i).ColumnWidth
    Next i

    ' Копируем высоту строк
    For j = начRow To конRow
        wsВременный.Rows(j).RowHeight = wsДанные.Rows(j).RowHeight
    Next j

    ' Скопируем диапазон как рисунок на временный лист
    rngКопировать.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    wsВременный.Range(начЯчейка).Select
    wsВременный.Paste

    ' Выделим диапазон на временном листе
    wsВременный.Range(начЯчейка & ":" & конЯчейка).Select

    ' Сохраним диапазон как PNG
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With wsВременный.Range(начЯчейка & ":" & конЯчейка)
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        sName = ActiveWorkbook.FullName & "_" & ActiveSheet.Name & "_Range"
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Parent.Select
            .Paste
            .Export Filename:=sName & ".png", FilterName:="PNG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    ' Удалим временный лист
    On Error Resume Next
    Application.DisplayAlerts = False
    ThisWorkbook.Sheets("ВременныйЛист").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

End Sub