Save as with current file path and format added

rjplante

Well-known Member
Joined
Oct 31, 2008
Messages
528
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:

VBA 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
 

Excel Facts

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,791
Office Version
  1. 2013
Platform
  1. Windows
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 ...

VBA Code:
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
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,791
Office Version
  1. 2013
Platform
  1. Windows
You are welcome and thanks for letting me know.
 

Forum statistics

Threads
1,140,929
Messages
5,703,225
Members
421,285
Latest member
Bebek

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top