Set NewWB = Workbooks.Add

Private Sub Save_as()
10  With Application.FileDialog(msoFileDialogSaveAs)
20      .InitialFileName = ThisWorkbook.Path & "\" & "Сравнение"
30      If .Show = 0 Then Exit Sub
40      ThisWorkbook.ActiveSheet.Copy
50      Application.DisplayAlerts = False
60      .Execute
70      Application.DisplayAlerts = True
80  End With
90  ActiveWorkbook.Close False
End Sub

Private Sub Save_as()
    With Application.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = ThisWorkbook.Path & "\" & "Сравнение"
        If .Show = 0 Then Exit Sub
        ThisWorkbook.ActiveSheet.Copy
        Application.DisplayAlerts = False
        .Execute
        Application.DisplayAlerts = True
    End With
    ActiveWorkbook.Close False
End Sub

Private Sub SaveSheets_Click()
Dim Fname As String
     Application.ScreenUpdating = False
     Fname = ThisWorkbook.Path & "\" & Sheets("Sheet1").Range("A1").Value & " " & Range("B1").Text & ".xls" 'тут название файла состоит из названия фирмы и нр. счета
     Sheets(Array("Sheet1", "Sheet2")).Copy 'указываем листы, которые хотим оставить
     Sheets("Sheet1").Shapes("SaveSheets").Delete 'удаляем ненужные кнопки (в моем случае у меня есть кнопки, которые должны остаться)
     With ActiveWorkbook
          Application.DisplayAlerts = False
          .SaveAs Filename:=Fname
          Application.ScreenUpdating = True
          Application.DisplayAlerts = True
          '.Close
     End With
     Workbooks("Book_Save.xls").Close 0
End Sub

Sub Лист_в_файл() 'Сохранить текущий лист.
     Dim List$, iPath$
    
     iPath = "D:\Папка\папка\" ' конкретный адрес для сохранения нового файла
    
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     List = ActiveSheet.Name
     Sheets(List).Copy
     Sheets(List).UsedRange.Value = Sheets(List).UsedRange.Value
     Sheets(List).Buttons.Delete 'Удаляем кнопки
     'Sheets(List).DrawingObjects.Delete 'Удаляем все элементы
     ActiveWorkbook.SaveAs iPath & List '& ".xls"
     ActiveWorkbook.Close False
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "Готово!"
  End Sub

'сохранить лист в отдельном файле
'sSheetName - имя сохраняемого листа (если такого нет - ни чего не делается)
'sNewFileName - имя файла (если не задано - берется имя листа)
'sNewPath - куда сохраняем, если не задано, в текущую
'sRngDelList - если надо указываем диапазоны столбцов для удаления
'bDelFurmula - если указано - удаляем формулы и ссылки
'sSubRun - если нужна дополнительная обработка - укажим нужную процедуру
Function fnSheetsSave(ByVal sSheetName As String, _
                         Optional ByVal sNewFileName As String = "", _
                         Optional ByVal sNewPath As String = "", _
                         Optional ByVal sRngDelList As String = "", _
                         Optional ByVal bDelFurmula As Boolean = False, _
                         Optional ByVal sSubRun As String = "") As Boolean
                   
Dim sFullFileName As String, arDelCol, iI As Integer, sCol As String
Dim strPS As String: strPS = Application.PathSeparator

     fnSheetsSave = False

     If Not fnSheetsIsExist(sSheetName) Then Exit Function
      
     TRC.Pop "fnSheetsSave"
     TRC.INFO "Сохранение листа в отдельную книгу", eColorBloc
      
     If sNewFileName = "" Then sNewFileName = sSheetName
      
mChkPath:
     'проверим и если что, сформируем путь
     If sNewPath = "" Then
         sNewPath = ActiveWorkbook.path & strPS
     Else
         If Right(sNewPath, 1) <> strPS Then sNewPath = sNewPath & strPS
         If Not fnPathIsExists(sNewPath) Then
             sNewPath = ""
             GoTo mChkPath
         End If
     End If
      
     'создаем полный путь к новому файлу
     sFullFileName = sNewPath & sNewFileName & IIf(fnGetFileExt(sNewFileName) = "", ".xls", "")
      
     'возможен долгий процесс, поэтому
     'дадим возможность поработать другим
     DoEvents
      
     On Error Resume Next
     'создаем копию листа...
     'создается новая книга и она становится активной
     ThisWorkbook.Sheets(sSheetName).Copy
     TRC.NOERROR "Лист скопирован в новую книгу (" & sSheetName & ")"
     If TRC.IFERROR("ОШИБКА копирования листа (" & sSheetName & ") %1") Then GoTo lEXITfnSheetsSave
     'после возможно долгого процесса
     'дадим возможность поработать другим
     DoEvents
      
     Application.ScreenUpdating = False
      
     If bDelFurmula = True Then
         'убираем ссылки и формулы
         ActiveSheet.Range("A1").CurrentRegion.Value = ActiveSheet.Range("A1").CurrentRegion.Value
         TRC.INFO "Формулы удалены"
     End If
      
     'однозначно убираем перенос по словам
     ActiveSheet.Range("A1").CurrentRegion.WrapText = False
      
     'если указаны столбцы на удаление - удалим их
     If sRngDelList <> "" Then
         arDelCol = Split(sRngDelList, " ")
         For iI = 0 To UBound(arDelCol)
             sCol = arDelCol(iI)
             ActiveSheet.Range(sCol).Delete
         Next iI
         TRC.INFO "Столбцы удалены (" & sRngDelList & ")"
     End If
      
     'если указана дополнительная функция для обработки - выполним ее
     If sSubRun <> "" Then
         Application.Run sSubRun
         TRC.INFO "Функция дополнительной обработки выполнена (" & sSubRun & ")"
     End If
      
     'сохраняем файл со всеми изменениями
     ActiveWorkbook.SaveCopyAs sFullFileName
     ActiveWorkbook.Close SaveChanges:=False
     TRC.NOERROR "Новая книга сохранена (" & sFullFileName & ")"
     If TRC.IFERROR("ОШИБКА! Книга не сохранена (" & sFullFileName & ") %1") Then GoTo lEXITfnSheetsSave
      
     fnSheetsSave = True
      
lEXITfnSheetsSave:

     Application.ScreenUpdating = True
      
     TRC.Push

End Function

Sub Save_as()
10 With Application.FileDialog(msoFileDialogSaveAs)
20 .InitialFileName = [b3] & " " & [b8]
30 If .Show = 0 Then Exit Sub
40 ThisWorkbook.ActiveSheet.Copy
50 Application.DisplayAlerts = False
60 .Execute
70 Application.DisplayAlerts = True
80 End With
90 ActiveWorkbook.Close False
End Sub

40 ActiveWorkbook.ActiveSheet.Copy