Sub Сохранить_лист()
    Dim path As String, iLinks As Variant, I As Long
    Dim vopros As VbMsgBoxResult
    Dim sFilename As String
 
    vopros = MsgBox("Сохранить форму?", vbYesNo + vbQuestion, "Сохранение")
    If vopros = vbNo Then Exit Sub
    
    Application.ScreenUpdating = False
    
    path = ThisWorkbook.path
    If IsEmpty(ThisWorkbook.Worksheets("Лист1").Range("B10")) Then
        MsgBox "Не указано имя листа в ячейке B10 на Лист1", vbExclamation, "Внимание"
        Exit Sub
    End If
    sFilename = ThisWorkbook.Worksheets("Лист1").Range("B10").Value
    ActiveSheet.Copy
    iLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(iLinks) Then
        For I = 1 To UBound(iLinks)
            ActiveWorkbook.BreakLink Name:=iLinks(I), Type:=xlExcelLinks
        Next I
    End If
    
    If ActiveSheet.Shapes.Count > 0 Then ActiveSheet.Shapes(1).Delete
        
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs path & Application.PathSeparator & ActiveSheet.Name & " " & sFilename & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    
    ActiveWorkbook.Close (False)
    
    Application.ScreenUpdating = True
    MsgBox "Форма сохранена в текущую папку.", vbInformation, "Сообщение:"
End Sub