在Saveas对话框中将工作表另存为预命名文件的VBA代码

Question

I have been trying a number of codes out there and none seem to work. The code below is the closest I have found to what I am trying to achieve, yet something is still amiss.

I want to move a sheet "consolidated" to a new workbook and save the workbook as a pre-populated file name Consolidated.xlsx. I want the dialogue box to pop up so the user just selects the folder they want. It appears the code works as expected, however when you click save it doesn't actually produce the saved file.

Any help is greatly appreciated.

Thank you

Sub Export()
Dim pathh As Variant

    ActiveWorkbook.Sheets("consolidated").Copy
    pathh = Application.GetSaveAsFilename( _
            FileFilter:="xlWorkbookDefault Files (*.xlsx), *.xlsx", _
            Title:="Consolidated", _
            InitialFileName:=filenamestring)
Application.DisplayAlerts = True
End Sub

Another attempt that saves the file, but does not show dialogue box in terms of where to save it:

Application.Goto ActiveWorkbook.Sheets("consolidated").Cells(1, 1)
ActiveSheet.Copy
ActiveWorkbook.SaveAs filename:=("Consolidated"), FileFormat:=xlOpenXMLWorkbook
ActiveWorkbook.Close savechanges:=False

Answer 1

You can try:

Sub Export()
    Dim pathh As Variant

    pathh = Application.GetSaveAsFilename( _
        FileFilter:="xlWorkbookDefault Files (*.xlsx), *.xlsx", _
        Title:="Consolidated", _
        InitialFileName:="Consolidated.xlsx")
    If pathh <> False then
        ActiveWorkbook.Sheets("consolidated").Copy
        ActiveWorkbook.Close Filename:=pathh
    End If
End Sub

Answer 2

Since the .SaveAs messes with the current file, I try not to use it.

This is more or less what I use to create template files, but modified to create regular files.

Public Sub CreateTemplate(Sheet As Excel.Worksheet, TemplateFile As String)
Dim SaveFormat As Long, SheetsInNewWorkbook As Long
Dim oBook As Excel.Workbook
Dim FileFormat As Integer

    ' Delete the old file, if it exists (to avoid the possible overwrite prompt later)
    On Error Resume Next
    Kill (TemplateFile)
    On Error GoTo 0

    'Remember the user's setting
    SaveFormat = Application.DefaultSaveFormat
    SheetsInNewWorkbook = Application.SheetsInNewWorkbook

    ' Change the DefaultSaveFormat, which controls the format when creating a new workbook.
    'Set the file format to the new 2007+ (.xlsx) format (with 1048576 rows), with 1 sheet
    Application.DefaultSaveFormat = xlOpenXMLWorkbook   '51
    Application.SheetsInNewWorkbook = 1
    'If you want the old 97-2003 (.xls) format (65536 rows), use
    'Application.DefaultSaveFormat = xlWorkbookNormal    '-4143

    ' Create a new Workbook
    Set oBook = Application.Workbooks.Add

    'Set DefaultSaveFormat & SheetsInNewWorkbook back to the user's settings
    Application.DefaultSaveFormat = SaveFormat
    Application.SheetsInNewWorkbook = SheetsInNewWorkbook

    ' Copy the sheet to the new Workbook
    Sheet.Copy After:=oBook.Sheets(1)
    ' Make sure the sheet is Visible (since my templates are hidden sheets)
    oBook.Sheets(2).Visible = True
    ' Supress the prompt to delete the blank Sheet(1)
    Application.DisplayAlerts = False
    oBook.Sheets(1).Delete

    ' Set the save format...
    FileFormat = xlOpenXMLWorkbook   '51
    ' For templates, use
    'FileFormat = xlTemplate    '17

    ' Save the file
    oBook.SaveAs Filename:=TemplateFile, FileFormat:=FileFormat, ReadOnlyRecommended:=False, CreateBackup:=False

    ' Return the prompts to normal
    Application.DisplayAlerts = True
    ' Close the Workbook, and clear the memory
    oBook.Close
    Set oBook = Nothing
End Sub

You can just call it easy enough, like this:

CreateTemplate ActiveSheet, pathh