Save sheets in a workbook to the saved location of the workbook with specific filename

[ranjanagarwal]

I have a workbook "Test" with sheets "A", "B", "C" etc. I am looking to move each of these sheets and save them in the same location as workbook "Test" using a file name from a cell in the sheet.

I am trying to use the following code for the above that I found in one of the MrExcel threads: It only works to save the first sheet. After that it gives Script out of range error pointing to the first saved sheet. Any help will be greatly appreciated.

    Dim Folder As String, FileName As String, FilePath As String, SheetName As String, Msg As String
  
    Dim DestWB As Workbook
  
    Folder = Workbooks(1).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").Move
    End If
    
    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
    
    
    Workbooks(1).Activate
    
    Sheets("Sheet17").Select
    If IsEmpty(Range("A2").Value) = False Then
          
    Sheets("Sheet17").Move
    End If
    
    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
    Workbooks(1).Activate

 

[dmt32]

Normally you would not hard code the sheet names as once code is run, the names are no longer valid & you get the error mentioned.
To help forum to understand what you want to do, in your workbook, what would determine if the sheet is to be moved & saved as at least ONE sheet must remain in the workbook.

For example do you need to move & save all sheets except the first sheet in the workbook or perhaps all sheet but not a sheet named "Master"?

Dave

 

[ranjanagarwal]

Hi Dave,
Thanks for your reply.

"Schedule - Casual" sheet will always be there in the master workbook as they are not moved out. Not sure if this is what you were asking.

 

[rlv01]

If you describe your problem in terms of Workbook "Test" and worksheets "A", "B", "C" but then when you post your code it contains none of those names, it just confuses everyone. You should decide on the names that you need:

Name of the the workbook containing the macro.
Name of the workbook containing the sheets to be moved.
Names of the worksheets to be moved to a new workbook
Name of each new workbook to be saved.

 

[ranjanagarwal]

If you describe your problem in terms of Workbook "Test" and worksheets "A", "B", "C" but then when you post your code it contains none of those names, it just confuses everyone. You should decide on the names that you need:

Name of the the workbook containing the macro.
Name of the workbook containing the sheets to be moved.
Names of the worksheets to be moved to a new workbook
Name of each new workbook to be saved.

Apologies. I just used those names as an example. Actual names are
Workbook name: WKE02SEP V1. This will change for every working week.
Sheet names that need to be moved: Sheet3 to Sheet18
Sheet that stays in the workbook: Sheet1, Sheet2, Schedule - Casual etc

I have managed to put together following code that solves my problem. This reuses some code from another thread in this forum. I am sure there will be cleaner way to resolve this. PS: I am not a coder

Dim Folder As String
  
    Worksheets("Sheet18").Activate
    

  
    Folder = ActiveWorkbook.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
    Sheets("Sheet18").Select
    If IsEmpty(Range("A2").Value) = False Then
    Sheets("Sheet18").Move

    Set DestWB = ActiveWorkbook
    FileName = ActiveSheet.Range("N1").Value         'name of new .xlsx found in cell N1
  
    FilePath = Folder & FileName

    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    
    DestWB.Close True
    Application.DisplayAlerts = True
    End If
    'MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name

  
    Sheets("Sheet17").Select
    If IsEmpty(Range("A2").Value) = False Then
    Sheets("Sheet17").Move

    Set DestWB = ActiveWorkbook
    FileName = ActiveSheet.Range("N1").Value         'name of new .xlsx found in cell N1
  
    FilePath = Folder & FileName

    DestWB.SaveAs FileName:=FilePath, FileFormat:=xlOpenXMLWorkbook
    
    DestWB.Close True
    Application.DisplayAlerts = True
    End If
    'MsgBox "Worksheet " & SheetName & " saved to new workbook:" & vbCr & FilePath, vbOKOnly Or vbInformation, Application.Name