Dim sPath As String, sName As String, Sp As Shape, iFullName As String
    sPath = "C:\Users\Администратор\Desktop\Договора\" 
    sName = InputBox("Укажите номер договора.", "Номер договора", "Договор_№_")
    If sName = "" Then
        MsgBox "Вы не указали номер договора.", 48, "Ашыпка!"
        Exit Sub
    End If
    iFullName = sPath & sName & ".xlsx"
    If Dir(iFullName) <> "" Then
        MsgBox "Файл с таким именем уже существует. Попробуйте другой номер.", 64, "Для сведения."
    Else
        Sheets("Лист1").Copy
        For Each Sp In ActiveSheet.Shapes
            Sp.Delete
        Next
        ActiveWorkbook.SaveAs Filename:=sPath & sName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
    End If