Sub SaveFile()
    Dim F_Filename$, Folder$
    F_Filename$ = Split([d2], ".")(0)
    Folder$ = [d1] & F_Filename

    On Error Resume Next: MkDir Folder$

    ' вывод в ПДФ
    ActiveSheet.PageSetup.PrintArea = Application.InputBox("Выделите область печати", Default:="$A$1:$C$26", Type:=2)
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, filename:=Folder & "\" & F_Filename & ".pdf"

    ' сохранение в XLS
    Application.ScreenUpdating = False
    Err.Clear: ActiveSheet.Copy: DoEvents ' копируем активный лист (при этом создаётся новая книга)
    If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Folder & "\" & F_Filename & ".xls", xlWorkbookNormal
        ActiveWorkbook.Close False ' закрываем сохранённый файл
    End If
    Application.ScreenUpdating = True
End Sub

Sub SaveFile()
    Dim F_Filename$, Folder$, Folder2$
    Dim strDate As String
    Dim strPath As String
    Dim DogNumb As String
    Dim wsTmpSh As Worksheet
    Dim Rgg As Range
    Set Rgg = ActiveSheet.Range("A1:F43")
    strPath = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ"
    Dim sFileName As String, sNewFileName As String
    Dim a As String
    a = Range("F3")
    
   DogNumb = Sheets("ФУРШЕТ").Range("F4").Value
    
    F_Filename$ = [C4] 'Split([C4], ".")(0)
    Folder$ = strPath & "\" & [C5] & " " & F_Filename
    Folder2$ = strPath & "\" & "КАРТИНКИ"
    strDate = Format(ActiveSheet.Range("$C$5"), "dd/mm/yy")
    On Error Resume Next: MkDir Folder$
 
     Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' вывод в PDF
    ActiveSheet.PageSetup.PrintArea = "$A$1:$F$43" ', Type:=2)
    Подготовить
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Folder & "\" & strDate & " " & F_Filename & ".pdf"

    ' сохранить JPG
        With Rgg
        .CopyPicture
        Set wsTmpSh = ThisWorkbook.Sheets.Add
        With wsTmpSh.ChartObjects.Add(0, 0, .Width, .Height).Chart
            .ChartArea.Border.LineStyle = 0
            .Paste
            .Export Filename:=Folder2 & "\" & strDate & " " & "ДОГОВОР (Ю)-" & DogNumb & " " & strDate & " " & ".jpeg", FilterName:="JPG"
            .Parent.Delete
        End With
    End With
    wsTmpSh.Delete

    ' сохранение в XLS

    Err.Clear: ActiveSheet.Copy: DoEvents ' копируем активный лист (при этом создаётся новая книга)
    If Err Then Exit Sub        ' произошла какая-то ошибка при попытке копирования листа

    ' убеждаемся, что активной книгой является копия листа
    If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
        ' сохраняем файл под заданным именем в формате Excel 2003
        ActiveWorkbook.SaveAs Folder & "\" & strDate & " " & F_Filename & ".xls", xlWorkbookNormal
        ActiveWorkbook.Close False ' закрываем сохранённый файл
    End If
 
 
    Вернуть
    Select Case a
    Case "Ф"
        sFileName = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ\ДОГОВОР ФИЗ ЛИЦО.doc"    'имя файла для копирования
        sNewFileName = Folder & "\" & "ДОГОВОР (Ф)-" & DogNumb & ". " & strDate & ".doc"     'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    
    FileCopy sFileName, sNewFileName 'копируем файл
    Case "Ю"
            sFileName = "C:\Users\Alexander\Desktop\Константин\МЕРОПРИЯТИЯ\ДОГОВОР ЮР ЛИЦО.doc"    'имя файла для копирования
        sNewFileName = Folder & "\" & "ДОГОВОР (Ю)-" & DogNumb & ". " & strDate & ".doc" 'имя копируемого файла. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    FileCopy sFileName, sNewFileName 'копируем файл
    End Select
     Sheets("ФУРШЕТ").Range("F4").Value = _
     Sheets("ФУРШЕТ").Range("F4").Value + 1
'  ThisWorkbook.Save
    Shell "explorer.exe " & Folder, vbMaximizedFocus
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Sub Подготовить()
 Dim Rng As Range
    Set Rng = Range("A1:F43")
    With Rng.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A2:F2,A11:F11").Interior.Color = RGB(220, 220, 220)
    Range("F3:F4").Font.Color = vbWhite
End Sub
Sub Вернуть()
    Dim Rng As Range
    Set Rng = Range("A1:F43")
    With Rng.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("F3:F4").Font.Color = vbRed
End Sub