Sub ZoomImage()
   
    Const ZOOM_RATIO# = 3    ' коэффициент увеличения изображения
    Const STEPS_COUNT& = 20    ' количество промежуточных шагов при увеличении
    Const ZOOM_SPEED# = 2   ' скорость увеличения / уменьшения картинки ( от 0 до 10)

    On Error Resume Next: Err.Clear: Dim sha As Shape, s_sha As Shape, i&
    Set s_sha = ActiveSheet.Shapes(Application.Caller)
    If Err Then Exit Sub    ' выход, если макрос вызван не щелчком на картинке

    If s_sha.Name Like "BigImage_*" Then    ' щелчок на увеличенной картинке
        With s_sha
            cx1# = .Left + .Width / 3: cy1# = .Top + .Height / 4
            dw# = .Width / STEPS_COUNT&
            dt# = ZOOM_SPEED# / 50 / STEPS_COUNT&

            For i& = 1 To STEPS_COUNT&    ' в цикле уменьшаем картинку
                t = Timer: .Width = .Width - dw#
                .Left = cx1# - .Width / 3: .Top = cy1# - .Height / 3
                While Timer - t < dt#: DoEvents: Wend
            Next i
            .Delete    ' а потом удаляем её
        End With

    Else    ' щелчок на исходной картинке, - создаём её копию, и увеличиваем
        For Each sha In ActiveSheet.Shapes
            If sha.Name Like "BigImage_*" Then sha.Delete
        Next

        Set sha = s_sha.Duplicate    ' создаем копию картинки
        sha.Top = s_sha.Top: sha.Left = s_sha.Left    ' помещаем копию поверх исходной
        sha.Name = "BigImage_" & Timer    ' переименовываем изображение
        sha.LockAspectRatio = 1

        ' если есть закреплённые столбцы и строки
        TopRowsHeight# = Range("1:1").RowHeight    ' закреплена первая строка
        LeftColumnsWidth# = 0    ' закреплённых столбцов нет

        With sha
            cx1# = .Left + .Width / 2: cy1# = .Top + .Height / 2

            cx2# = Columns(ActiveWindow.ScrollColumn).Left - LeftColumnsWidth# + _
                   ActiveWindow.Width / 2 * 100 / ActiveWindow.Zoom
            cy2# = Rows(ActiveWindow.ScrollRow).Top - TopRowsHeight# + _
                   ActiveWindow.Height / 2 * 100 / ActiveWindow.Zoom

            dw# = .Width * (ZOOM_RATIO# - 1) / STEPS_COUNT&
            dx# = (cx2# - cx1#) / STEPS_COUNT&: dy# = (cy2# - cy1#) / STEPS_COUNT&
            cx# = cx1#: cy# = cy1#: dt# = ZOOM_SPEED# / 50 / STEPS_COUNT&

            For i& = 1 To STEPS_COUNT&
                t = Timer: cx# = cx# + dx#: cy# = cy# + dy#
                .Width = .Width + dw#: .Left = cx# - .Width / 2: .Top = cy# - .Height / 2
                While Timer - t < dt#: DoEvents: Wend
            Next i
        End With
    End If
End Sub

Sub SAVE()

Sheets("СЧЕТ").Select
ActiveSheet.Range("$AI$15:$AL$30").AutoFilter Field:=1, Criteria1:="<>"

     Dim F_Filename As String, Folder As String
     With Application
         .DisplayAlerts = False
         With ActiveSheet
             Set FSO = CreateObject("Scripting.FileSystemObject")
             F_Filename = Split(.[AN4], ",")(0)
             Folder = F_Filename
             If Not FSO.FolderExists(Folder) Then FSO.CreateFolder Folder
             Set FSO = Nothing
             .PageSetup.PrintArea = "A1:AM65"
             ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                     Filename:= _
                 Folder & "/" & .[AN4], _
                     Quality:=xlQualityHigh, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                     OpenAfterPublish:=False
         End With
         .DisplayAlerts = True
     End With
     
End sub