Сохранение текущего листа Excel в отдельный файл

ActiveWorkbook.PublishObjects.Add(xlSourceSheet, "C:\temp\777.htm", "Лист1").Publish

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
 
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
 
Dim OFName As OPENFILENAME
 
Private Function ShowSave() As String
    OFName.lStructSize = Len(OFName)
    OFName.hwndOwner = Hwnd
    OFName.hInstance = Application.hInstance
    OFName.lpstrFilter = "html (*.html)" + Chr$(0) + "*.html" + Chr$(0)
    OFName.lpstrFile = Space$(254)
    OFName.nMaxFile = 255
    OFName.lpstrFileTitle = Space$(254)
    OFName.nMaxFileTitle = 255
    OFName.lpstrInitialDir = "C:"
    OFName.lpstrTitle = ""
    OFName.flags = 0
    If GetSaveFileName(OFName) Then
        ShowSave = Trim$(OFName.lpstrFile)
    Else
        ShowSave = ""
    End If
End Function

Private Sub CommandButton1_Click()
    Dim sFile As String
    sFile = ShowSave
    If sFile <> "" Then
        ActiveWorkbook.ActiveSheet.SaveAs Filename:=sFile, FileFormat:=xlHtml 'формат html
    End If
End Sub

Private Sub Несохранять()
Dim №СФ As Variant
    Sheets("СчФ").Select       'Открытие листа "СчФ"
    Application.ScreenUpdating = False  'Отключение отображения результатов на экране
With ActiveSheet                        'Переменным присваиваются введенные в бланк данные
    №СФ = .Range("ном").Value
End With
    Sheets("СчФ").Copy Before:=Sheets(1)
    Range("Дат").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
    Range("Поставщик").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
    Range("Плательщик").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
    Range("суммНДС").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
    Range("суммсНДС").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    With Selection.Interior
        .ColorIndex = 2
        .Pattern = xlSolid
    End With
        'копирование ТН-2 ?
'
'
'
'
'
'
'
 Sheets("СчФ (2)").Select
    Sheets("СчФ (2)").Move
    Sheets("СчФ (2)").Select
    Sheets("СчФ (2)").Name = "СчФ"
    Range("A1").Select
    SavedName = Application.GetSaveAsFilename(InitialFileName:="СчФ_" & №СФ & ".xls", _
    FileFilter:="Рабочие книги (*.xls),*.xls")
    If SavedName = False Then End
    ActiveWorkbook.SaveAs SavedName
    ActiveWindow.Close
    Sheets("СчФ").Select       'Открытие листа "СчФ"
    Application.ScreenUpdating = True
End Sub

Sub wshSave()
  Dim WbMain As Workbook
    Dim Wb As Workbook
    Dim sh As Worksheet
    Dim DateString As String
    Dim FolderName As String
    Application.EnableEvents = False
    Set WbMain = ActiveWorkbook
    FolderName = WbMain.Path & "\Archive"
    On Error Resume Next
    MkDir FolderName
    If ActiveSheet.Visible = -1 Then
            ActiveSheet.Copy
            Set Wb = ActiveWorkbook
            Wb.SaveAs FolderName _
                      & "\" & Wb.Sheets(1).Name & ".xls"
            Wb.Close False
    End If
    MsgBox "Лист " & ActiveSheet.Name & " в виде отдельного файла сохранён в папку " & FolderName
    ActiveWindow.SelectedSheets.Delete
    Application.EnableEvents = True
End Sub