Sub SaveSheet(ws As Worksheet, sPath As String)
  Dim sName As String, Sp As Shape, iFullName As String
  Application.DisplayAlerts = False
  sName = ws.Range("b2").Value
  If sName = "" Then
    MsgBox "Вы не указали имя файла.", 48, "Ошибка!"
    Application.DisplayAlerts = True: Exit Sub
  End If
  iFullName = sPath & sName & ".xlsx"
  If Dir(iFullName) <> "" Then
    MsgBox "Файл с таким именем уже существует. Попробуйте другой.", 64, "Для сведения."
  Else
    ws.Copy
    For Each Sp In ActiveSheet.Shapes
      Sp.Delete
    Next
    ActiveWorkbook.SaveAs Filename:=sPath & sName & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
  End If
  Application.DisplayAlerts = True
End Sub


Sub SaveWorksheets()
  Dim wsht As Worksheet, pt$
  pt = ThisWorkbook.Worksheets(1).[a2]
  For Each wsht In ThisWorkbook.Worksheets
    SaveSheet wsht, pt
  Next
End Sub

Sub SaveSheet(ws As Worksheet, iFullName As String)
  Dim Sp As Shape
  Application.DisplayAlerts = False
  If Dir(iFullName) <> "" Then
    MsgBox "Файл с именем" & vbLf & iFullName & vbLf & _
    "уже существует. Попробуйте другой.", 64, "Для сведения."
  Else
    ws.Copy
    For Each Sp In ActiveSheet.Shapes
      Sp.Delete
    Next
    ActiveWorkbook.SaveAs Filename:=iFullName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
  End If
  Application.DisplayAlerts = True
End Sub


Sub SaveWorksheets()
  Dim r&, pt$
  With ThisWorkbook.Worksheets(1)
    pt = .[a2]: r = 3
    Do While Not IsEmpty(.Cells(r, 1))
      SaveSheet ThisWorkbook.Worksheets(.Cells(r, 2).Value), pt & .Cells(r, 1) & "xlsx"
      r = r + 1
    Loop
  End With
End Sub