Save as with current file path and format added

[rjplante]

I have a worksheet that I want to save as a separate workbook. I would like to save as dialogue box to appear with an initial file name listed (as a suggestion) which the user can fully edit. I also want tot file format to be defined as xlsx and the file path to match the current file which the user can fully change. I have some of code listed below, which is from a previous version that was much more locked down. I want to have the user select the destination and enter the file name, and then run the rest of the macro to generate the file. What do I have to change to get this to work right.

Current macro code:

Sub SAVE_AS_FILE()


Dim sFile As String
Dim Fpath As String
Dim TransferRow As Long
Dim Dest As Workbook
Dim wb As Workbook
Dim Source As Range
Dim FileExtStr As String
Dim FileFormatNum As String

' This will generate the save as dislogue box with the suggested file name in it allowing the user to change the name and file location, but when they select OK, it will just save the file, and not generate the separate sheet. 
sFile = Application.GetSaveAsFilename(InitialFileName:="QUOTE# Component List")

Fpath = ThisWorkbook.Path

    FileExtStr = ".xlsx": FileFormatNum = 51

'   Save sheet with defined name
    Sheets("Component List").Activate
    TransferRow = Cells(Rows.Count, 1).End(xlUp).Row

'   Define the block of data to create a sheet from.
    Set Source = Nothing
    On Error Resume Next
    Set Source = Sheets("Component List").Range("A1:B" & TransferRow)
    On Error GoTo 0

    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
            
    With Dest
        .SaveAs sFile & FileExtStr, FileFormat:=FileFormatNum
    End With
    
    'Workbooks(sFile).Activate
    ActiveWindow.DisplayGridlines = False

'   Save the Component List
    With ActiveWorkbook
        .Save
        .Close SaveChanges:=False
    End With
    
    MsgBox "A new spreadsheet has been created and saved as: " & sFile & vbCrLf & _
            "In this location: " & Fpath


End Sub

 

[GWteB]

The code below is likely to do as wanted, assuming that you're aware of the fact that only the first two columns are saved ...

Sub SAVE_AS_FILE()

    Dim TransferRow As Long
    Dim Source      As Range
    Dim Dest        As Range

    Dim FileFullName    As Variant
    Dim FileFilter      As String
    Dim FileInitial     As String

    FileInitial = ThisWorkbook.Path & "\" & "QUOTE# Component List"
    FileFilter = "Excel Workbook (*.xlsx), *.xlsx"
    
    ' Get location and filename to be used for saving
    FileFullName = Application.GetSaveAsFilename(InitialFileName:=FileInitial, FileFilter:=FileFilter)

    Application.ScreenUpdating = False

    If Not VarType(FileFullName) = vbBoolean Then
        
        '   Save sheet with defined name
        With ThisWorkbook.Sheets("Sheet1")
            TransferRow = .Cells(.Rows.Count, 1).End(xlUp).Row
            '   Define the block of data to create a sheet from.
            Set Source = .Range("A1:B" & TransferRow)
        End With

        Set Dest = Workbooks.Add(xlWBATWorksheet).Sheets(1).Cells(1)

        Source.Copy
        With Dest
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            .Select
        End With
        Application.CutCopyMode = False
        ActiveWindow.DisplayGridlines = False

        With Dest.Parent.Parent
            .SaveAs FileFullName, xlOpenXMLWorkbook
            .Close False
        End With

        MsgBox "A new spreadsheet has been created and saved as:" & vbNewLine & FileFullName

    Else

        MsgBox "Cancel was pressed, file has not been saved.", vbExclamation, "Save As attempt"
    End If
    Application.ScreenUpdating = True
End Sub

 

[rjplante]

Awesome thanks! I works perfectly.

 

[GWteB]

You are welcome and thanks for letting me know.