Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set WshShell = CreateObject("WScript.Shell")
    With ActiveSheet
        trgt_path$ = WshShell.RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Desktop") & _
            "\Отчет\" & .Range("B1").Value & "_" & .Range("A1").Value & "_" & .Range("C1").Value
    End With
    Me.SaveCopyAs trgt_path
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.ScreenUpdating = False
Dim awb As Workbook, nwb As Workbook
Set awb = ActiveWorkbook
With Worksheets("Аркуш1")
fn = .Cells(1, 2).Value & "_" & .Cells(1, 1).Value & "_" & .Cells(1, 3).Value
End With
pth = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Desktop") & _
            "\Отчет\" & fn & ".xlsx"
nsh = ActiveWorkbook.Sheets.Count
Set nwb = Workbooks.Add(1)
For x = nsh To 1 Step -1
awb.Sheets(x).Copy After:=nwb.Sheets(1)
Next
Application.DisplayAlerts = False
nwb.Sheets(1).Delete
nwb.SaveCopyAs Filename:=pth
nwb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
With Worksheets("Аркуш1")
fn = .Cells(1, 2).Value & "_" & .Cells(1, 1).Value & "_" & .Cells(1, 3).Value
End With
pth = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Desktop") & _
            "\Отчет\" & fn & ".xlsx"
 ThisWorkbook.SaveAs Filename:=pth, _
        FileFormat:=xlExcel12, CreateBackup:=False
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim WshShell As Object, oFS As Object
Dim target_path As String
    Set WshShell = CreateObject("WScript.Shell")
    Set oFS = CreateObject("Scripting.FileSystemObject")
    target_path = WshShell.SpecialFolders("Desktop") & "Отчет\" 'на рабочий стол в \отчет
    If Not oFS.FolderExists(target_path) Then 'проверка на наличие папки
        MsgBox "Папка " & Chr(34) & target_path & " не существует, создайте папку." & vbCrLf & _
               "Копия файла не сохранена.", 16
        Cancel = True
        Exit Sub
    End If
    With ActiveSheet
        target_path = target_path & .Range("B1").Value & "_" & .Range("A1").Value & "_" & .Range("C1").Value & ".xls"
    End With
    Me.SaveCopyAs target_path
End Sub 

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    ThisWorkbook.SaveAs Filename:=Range("Имя"), _
        FileFormat:=xlExcel12, CreateBackup:=False
End Sub