VBA: Save Sheet as xlsx file in original folder and original filename.

Status
Not open for further replies.

chuckp2022

New Member
Joined
May 3, 2022
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Ok, I’m new to VBA and I’m really struggling with getting a macro to do what I want it to do.

I have a spreadsheet (Office 365) with macros enabled (xlsm)

There are 4 sheets in the spreadsheet. One of them is a planned maintenance checklist. When the work/checklist is completed, I’d like to click a button to save the sheet with the original filename as xlsx in the folder where the original file is located. It should only be the sheet that has the checklist on it. I have already placed a ‘button’ on the page to start the macro. Just can’t get the macro to do what I want.

This is what I’d like.
I’d like it to suppress warning about saving it as xlsx, over writing an original file. Basically just do it, don’t ask questions!!
Save as the original filename but as xlsx.
Save to the original folder of the file.
As a bonus, remove the button that starts the macro. Not that important though.

I have a cell that gets the filename and it’s in (N1)
Here is what’s in cell N1:
=MID(CELL("filename"),FIND("[",CELL("filename"))+1,FIND("]",CELL("filename"))-FIND("[",CELL("filename"))-6)

I’ve been trying to use that as the fname

I’ve found many possible solutions, but they don’t do everything, and I don’t know enough about VBA to correct any issues.

This one almost works but has the wrong filename and saves is as xls, not xlsx. It’s in the correct folder though. Found it on MrExcel along with others. Can't seem to find one that does what I want.

---------
Sub Test()

' Copy activesheet to the new workbook
ActiveSheet.Copy
MsgBox "This new workbook will be saved as MyWb.xls(x)"

'Save new workbook as MyWb.xls(x) into the folder where ThisWorkbook is stored
ActiveWorkbook.SaveAs ThisWorkbook.Path & "\MyWb", xlWorkbookNormal
MsgBox "It is saved as " & ActiveWorkbook.FullName & vbLf & "Press OK to close it"

End Sub

---------

Any help would be appreciated.
 

Excel Facts

Which came first: VisiCalc or Lotus 1-2-3?
Dan Bricklin and Bob Frankston debuted VisiCalc in 1979 as a Visible Calculator. Lotus 1-2-3 debuted in the early 1980's, from Mitch Kapor.
Here's an example. If you want the file name to come from cell N1, you need to specify which worksheet N1 is located on, and the value in N1 must be a legal filename with an ".xlsx" file extension.

VBA Code:
'Save ActiveSheet to new WB w/ macro-free format while keeping original file open
Sub SaveXLSX()
    Dim Folder As String, FileName As String, FilePath As String, SheetName As String
    Dim DestWB As Workbook
    
    Folder = ThisWorkbook.Path
    FileName = "MyNewWorkbook.xlsx"                   'name of new .xlsx workbook
    'FileName = ActiveSheet.Range("N1").Value          'name of new .xlsx found in cell N1
    
    FilePath = Folder & FileName
    
    SheetName = ActiveSheet.Name
    ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
    
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close False
    Application.DisplayAlerts = True
    
    MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name
End Sub

For future posts , you should try to use code tags like I did above when posting your code. It makes it easier to read.

 
Upvote 0
Here's an example. If you want the file name to come from cell N1, you need to specify which worksheet N1 is located on, and the value in N1 must be a legal filename with an ".xlsx" file extension.

VBA Code:
'Save ActiveSheet to new WB w/ macro-free format while keeping original file open
Sub SaveXLSX()
    Dim Folder As String, FileName As String, FilePath As String, SheetName As String
    Dim DestWB As Workbook
   
    Folder = ThisWorkbook.Path
    FileName = "MyNewWorkbook.xlsx"                   'name of new .xlsx workbook
    'FileName = ActiveSheet.Range("N1").Value          'name of new .xlsx found in cell N1
   
    FilePath = Folder & FileName
   
    SheetName = ActiveSheet.Name
    ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
   
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close False
    Application.DisplayAlerts = True
   
    MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name
End Sub

For future posts , you should try to use code tags like I did above when posting your code. It makes it easier to read.

Thank you. I'll give this a try as soon as I get home.
 
Upvote 0

rlv01,​

Thank you very much. It almost works.
I unremarked the dynamic filename and remarked the static filename.
It’s saving the file to the directory just above where the file is.

i.e. File is located in:
C:\Users\myname\OneDrive\Planned Maint\XA\Vendor\Spreadsheets\file.xlsm

It’s creating the file in:
C:\Users\myname\OneDrive\Planned Maint\XA\Vendor

So the resulting filename is: Spreadsheetsfile.xlsx
The value in N1 = file.xlsx

I get the same results on either filename, static or dynamic.

Thoughts?
 
Upvote 0

rlv01,​

Thank you very much. It almost works.
I unremarked the dynamic filename and remarked the static filename.
It’s saving the file to the directory just above where the file is.

i.e. File is located in:
C:\Users\myname\OneDrive\Planned Maint\XA\Vendor\Spreadsheets\file.xlsm

It’s creating the file in:
C:\Users\myname\OneDrive\Planned Maint\XA\Vendor

So the resulting filename is: Spreadsheetsfile.xlsx
The value in N1 = file.xlsx

I get the same results on either filename, static or dynamic.

Thoughts?
I've been trying stuff.
I rearranged where the filename is and added the filepath to the spreadsheet.
The filename is in cell N3 and the filepath is in N4.
Can I use that somehow?
 
Upvote 0

rlv01,​

Thank you very much. It almost works.
I unremarked the dynamic filename and remarked the static filename.
It’s saving the file to the directory just above where the file is.

i.e. File is located in:
C:\Users\myname\OneDrive\Planned Maint\XA\Vendor\Spreadsheets\file.xlsm

It’s creating the file in:
C:\Users\myname\OneDrive\Planned Maint\XA\Vendor

So the resulting filename is: Spreadsheetsfile.xlsx
The value in N1 = file.xlsx

I get the same results on either filename, static or dynamic.

Thoughts?


This one has some debug code to help you understand what folder ThisWorkbook is in and where the new file will be saved.
VBA Code:
'Save ActiveSheet to new WB w/ macro-free format while keeping original file open
Sub SaveXLSX()
    Dim Folder As String, FileName As String, FilePath As String, SheetName As String, Msg As String
    
    Dim DestWB As Workbook
    
    Folder = ThisWorkbook.Path
    If Folder = "" Then                               'case when workbook is new and unsaved
        Folder = CurDir$
    End If
    
    If Not Right(Folder, 1) = "\" Then
        Folder = Folder & "\"                         'add backslash if not present
    End If
    
    FileName = "MyNewWorkbook.xlsx"                   'name of new .xlsx workbook
    'FileName = ActiveSheet.Range("N1").Value         'name of new .xlsx found in cell N1
    
    FilePath = Folder & FileName
    
    SheetName = ActiveSheet.Name
    
    'Debug code. These lines can be deleted later, once you have the functionality you want.
      Msg = "Folder for " & ThisWorkbook.Name & " is" & vbCr & "'" & Folder & "'"
      Msg = Msg & vbCr & vbCr & "File name: " & FileName
      Msg = Msg & vbCr & vbCr & "New file to be created: " & vbCr & "'" & FilePath & "'"
      If MsgBox(Msg & vbCr & vbCr & "Proceed?", vbOKCancel Or vbQuestion, "Debug Information") = vbCancel Then
          Exit Sub
      End If
    'End debug
    
    ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
    
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close False
    Application.DisplayAlerts = True
    
    MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name
End Sub
 
Upvote 0
Solution
I've been trying stuff.
I rearranged where the filename is and added the filepath to the spreadsheet.
The filename is in cell N3 and the filepath is in N4.
Can I use that somehow?



Yes, you can rearrange things to suit yourself. If you get the path from N4, it is up to you to be sure it contains a valid existing folder name or else you will get a runtime error.
VBA Code:
'Save ActiveSheet to new WB w/ macro-free format while keeping original file open
Sub SaveXLSX()
    Dim Folder As String, FileName As String, FilePath As String, SheetName As String, Msg As String
    
    Dim DestWB As Workbook
    
    'Folder = ThisWorkbook.Path
    Folder = Trim(ActiveSheet.Range("N4").Value)
       
    If Folder = "" Then                               'case when workbook is new and unsaved
        Folder = CurDir$
    End If
    
    If Not Right(Folder, 1) = "\" Then
        Folder = Folder & "\"                         'add backslash if not present
    End If
    
    'FileName = "MyNewWorkbook.xlsx"                   'name of new .xlsx workbook
    FileName = ActiveSheet.Range("N3").Value         'name of new .xlsx found in cell N3
    
    FilePath = Folder & FileName
    
    SheetName = ActiveSheet.Name
    
    'Debug code. These lines can be deleted later, once you have the functionality you want.
    Msg = "Folder for " & ThisWorkbook.Name & " is" & vbCr & "'" & Folder & "'"
    Msg = Msg & vbCr & vbCr & "File name: " & FileName
    Msg = Msg & vbCr & vbCr & "New file to be created: " & vbCr & "'" & FilePath & "'"
    If MsgBox(Msg & vbCr & vbCr & "Proceed?", vbOKCancel Or vbQuestion, "Debug Information") = vbCancel Then
        Exit Sub
    End If
    'End debug
    
    ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
    
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close False
    Application.DisplayAlerts = True
    
    MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name
End Sub
 
Upvote 0
This one has some debug code to help you understand what folder ThisWorkbook is in and where the new file will be saved.
VBA Code:
'Save ActiveSheet to new WB w/ macro-free format while keeping original file open
Sub SaveXLSX()
    Dim Folder As String, FileName As String, FilePath As String, SheetName As String, Msg As String
   
    Dim DestWB As Workbook
   
    Folder = ThisWorkbook.Path
    If Folder = "" Then                               'case when workbook is new and unsaved
        Folder = CurDir$
    End If
   
    If Not Right(Folder, 1) = "\" Then
        Folder = Folder & "\"                         'add backslash if not present
    End If
   
    FileName = "MyNewWorkbook.xlsx"                   'name of new .xlsx workbook
    'FileName = ActiveSheet.Range("N1").Value         'name of new .xlsx found in cell N1
   
    FilePath = Folder & FileName
   
    SheetName = ActiveSheet.Name
   
    'Debug code. These lines can be deleted later, once you have the functionality you want.
      Msg = "Folder for " & ThisWorkbook.Name & " is" & vbCr & "'" & Folder & "'"
      Msg = Msg & vbCr & vbCr & "File name: " & FileName
      Msg = Msg & vbCr & vbCr & "New file to be created: " & vbCr & "'" & FilePath & "'"
      If MsgBox(Msg & vbCr & vbCr & "Proceed?", vbOKCancel Or vbQuestion, "Debug Information") = vbCancel Then
          Exit Sub
      End If
    'End debug
   
    ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
   
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close False
    Application.DisplayAlerts = True
   
    MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name
End Sub
That's amazing. This code works perfectly. I've been working on this for 6 months (on & off).
Thank you sooo much.
Cheers.
 
Upvote 0
Glad I could help.
Hi,
I hope you can help. I am using the above code for resolve following problem:

Workbook "Test.xlsx" has multiple sheets e.g. Sheet1, Sheet2 etc. I am looking to copy/move each sheet and save it in the same location as the workbook "Test.xlsx"

Couple of issue that I am having.

As you can see from the screenshot, the copied sheet is getting saved in the Macro folder, not the workbook's folder. What am I doing wrong here?

Second, I am looking to copy and save a number of sheets as new workbook and close them. However when I run the code, it gives Run-time error (9) Subscript out of range. Screenshot and code attached for reference.

Any help will be greatly appreciated.
1662621324679.png
1662621366759.png


VBA Code:
'Save ActiveSheet to new WB w/ macro-free format while keeping original file open
Sub SaveXLSX()
    
    Dim Folder As String, FileName As String, FilePath As String, SheetName As String, Msg As String
  
    Dim DestWB As Workbook
  
    Folder = ThisWorkbook.Path
        
    If Folder = "" Then                               'case when workbook is new and unsaved
        Folder = CurDir$
    End If
  
    If Not Right(Folder, 1) = "\" Then
        Folder = Folder & "\"                         'add backslash if not present
    End If
  
    'FileName = "MyNewWorkbook.xlsx"                   'name of new .xlsx workbook
    FileName = ActiveSheet.Range("N1").Value         'name of new .xlsx found in cell N1
  
    FilePath = Folder & FileName
  
    'SheetName = ActiveSheet.Name
  
    'Debug code. These lines can be deleted later, once you have the functionality you want.
      Msg = "Folder for " & ThisWorkbook.Name & " is" & vbCr & "'" & Folder & "'"
      Msg = Msg & vbCr & vbCr & "File name: " & FileName
      Msg = Msg & vbCr & vbCr & "New file to be created: " & vbCr & "'" & FilePath & "'"
      If MsgBox(Msg & vbCr & vbCr & "Proceed?", vbOKCancel Or vbQuestion, "Debug Information") = vbCancel Then
          Exit Sub
      End If
    'End debug
  
    Sheets("Sheet18").Select
    If IsEmpty(Range("A2").Value) = False Then
    
    Sheets("Sheet18").Copy
    End If
    'ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
  
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close True
    Application.DisplayAlerts = True
  
    
   MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name

ThisWorkbook.Activate

    Sheets("Sheet17").Select
    If IsEmpty(Range("A2").Value) = False Then
    
    Sheets("Sheet17").Copy
    End If
    'ActiveSheet.Copy
    Set DestWB = ActiveWorkbook
  
    Application.DisplayAlerts = False
    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    DestWB.Close True
    Application.DisplayAlerts = True
  
    
   MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name


End Sub
 
Upvote 0
Status
Not open for further replies.

Forum statistics

Threads
1,213,513
Messages
6,114,072
Members
448,546
Latest member
KH Consulting

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
Back
Top