save as macro in excel

Question

I need a SaveAs Macro in Excel to save several files from one cell. So I have an Excel file called X. Within that file I have 5 sheets that need to be saved at another destination, and I also have a distribution sheet which is where I want to attach a macro to a button to save the files to the appropriate locations.

In my distribution list I have a cell with the location of where the 5 sheets need to be saved. I want to be able to just edit that cell and press the macro button to save as. For example if I wanted to save sheet AAA. Cell B3 “H:\Test\Saveasfolder\AAA (sheet name)“ - edit this then press macro save as.

Sub sb_Copy_Save_ActiveSheet_As_Workbook()
    Set wb = Workbooks.Add
    ThisWorkbook.Activate
    ActiveSheet.Copy
    Before:=wb.Sheets(1)
    wb.Activate
    wb.SaveAs "H:\Transaction Listing\Cluster 1\test3.xlsx"
End Sub

Sub sb_Copy_Save_ActiveSheet_As_Workbook() Set wb = Workbooks.Add ThisWorkbook.Activate ActiveSheet.Copy Before:=wb.Sheets(1) wb.Activate wb.SaveAs "H:\Transaction Listing\Cluster 1\test3.xlsx" End Sub — Nwaaaa
The issue is it does not link with a cell, I have to manually change the destination every time on vba. — Nwaaaa

Mark Moore Mark Moore · Accepted Answer · 2014-12-17T15:15:05

This code should work for you, hopefully comments are explanation enough

Sub MySaveAs()

Dim FName As String
Dim FPath As String
Dim NewWS As Workbook
Dim MySheets As Worksheet
Dim FileExtStr As String

    'Turn screen updating off to prevent flicker
    Application.ScreenUpdating = False

    FPath = ActiveCell.Value
    For Each MySheets In ActiveWorkbook.Worksheets
        Select Case MySheets.Name
            Case "AAA", "BBB", "CCC", "DDD", "EEE" 'will only do this for these sheet names, edit as required
                'Find out the file format to use based on current workbook
                If Val(Application.Version) < 12 Then
                    FileExtStr = ".xls": FileFormatNum = -4143
                Else
                    Select Case ThisWorkbook.FileFormat
                        Case 51, 52
                            FileExtStr = ".xlsx"
                            FileFormatNum = 51
                        Case 56:
                            FileExtStr = ".xls"
                            FileFormatNum = 56
                        Case Else:
                            FileExtStr = ".xlsb"
                            FileFormatNum = 50
                    End Select
                End If
                'set the file name
                FName = MySheets.Name & FileExtStr
                'Check if file alredy exists at the location
                If Dir(FPath & "\" & FName) <> "" Then
                    MsgBox "File " & FPath & "\" & FName & " already exists"
                Else
                    'create new workbook
                    Set NewWS = Workbooks.Add
                    'copy existing sheet
                    MySheets.Copy Before:=NewWS.Sheets(1)
                    'switch off alerts so no confirmation prompt is displayed
                    Application.DisplayAlerts = False
                    'switch off error handing just in case sheet doesnt exist whilst trying to delete it
                    On Error Resume Next
                    'Delete the default "Sheet1"
                    NewWS.Worksheets("Sheet1").Delete
                    'Switch error handling and alerts back on
                    Application.DisplayAlerts = True
                    On Error GoTo 0
                    'Save file using path from cell and current sheet name
                    NewWS.SaveAs Filename:=FPath & "\" & FName
                    'close the file
                    NewWS.Close
                End If
            Case Else
        End Select
    Next MySheets

    'Turn screen updating back on
    Application.ScreenUpdating = True

End Sub

There is no real validation of the current cell to check it is a valid folder path, will leave that to you

save as macro in excel

1 Answers