VBA Code to Save Worksheets as separate files

[warleque]

I have a sample spreadsheet where I have 3 worksheets that I would like to save as stand alone workbooks, but I would also like to password protect each workbook with a unique password.

I have a worksheet within the master called 'Setup' and I have the worksheet names stored in B2:B4 and the passwords are stored in C2:C4.

The below sample code will create the files as desired, but only the first password in the list is applied to all workbooks that are created.

Any help would be much appreciated, thanks in advance:

Option Explicit

Sub SaveSheets()

Dim worksheet_list As Variant
Dim worksheet_name As Variant
Dim pwd_list As Variant
'Dim pwd_name As Variant
Dim new_workbook As Workbook
Dim saved_folder As String

saved_folder = "C:\Users\warleque\OneDrive - Confluent Health\Desktop\TestExcel\"
pwd_list = ThisWorkbook.Sheets("Setup").Range("C2:C4")
worksheet_list = ThisWorkbook.Sheets("Setup").Range("B2:B4")


For Each worksheet_name In worksheet_list

On Error Resume Next

Set new_workbook = Workbooks.Add

ThisWorkbook.Worksheets(worksheet_name).Copy new_workbook.Worksheets(1)

new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51, password:=pwd_list
new_workbook.Close False

Next worksheet_name

MsgBox "Export complete", vbInformation


End Sub

 

[DanteAmor]

Now the names are in a variable of type Range.
Try this:

Sub SaveSheets()

  Dim worksheet_list As Range
  Dim worksheet_name As Range
  Dim pwd_list As Range
  'Dim pwd_name As Variant
  Dim new_workbook As Workbook
  Dim saved_folder As String
 
  saved_folder = "C:\Users\warleque\OneDrive - Confluent Health\Desktop\TestExcel\"
 
 
  Set worksheet_list = ThisWorkbook.Sheets("Setup").Range("B2:B4")
  Set pwd_list = ThisWorkbook.Sheets("Setup").Range("C2:C4")
 
  For Each worksheet_name In worksheet_list
   
    On Error Resume Next
   
    Set new_workbook = Workbooks.Add
   
    ThisWorkbook.Worksheets(worksheet_name).Copy new_workbook.Worksheets(1)
   
    new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51, Password:=worksheet_name.Offset(0, 1)
    new_workbook.Close False
 
  Next worksheet_name
 
  MsgBox "Export complete", vbInformation


End Sub

 

[warleque]

Now the names are in a variable of type Range.
Try this:

Sub SaveSheets()

  Dim worksheet_list As Range
  Dim worksheet_name As Range
  Dim pwd_list As Range
  'Dim pwd_name As Variant
  Dim new_workbook As Workbook
  Dim saved_folder As String
 
  saved_folder = "C:\Users\warleque\OneDrive - Confluent Health\Desktop\TestExcel\"
 
 
  Set worksheet_list = ThisWorkbook.Sheets("Setup").Range("B2:B4")
  Set pwd_list = ThisWorkbook.Sheets("Setup").Range("C2:C4")
 
  For Each worksheet_name In worksheet_list
  
    On Error Resume Next
  
    Set new_workbook = Workbooks.Add
  
    ThisWorkbook.Worksheets(worksheet_name).Copy new_workbook.Worksheets(1)
  
    new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51, Password:=worksheet_name.Offset(0, 1)
    new_workbook.Close False
 
  Next worksheet_name
 
  MsgBox "Export complete", vbInformation


End Sub

Thanks for the help, this created 3 workbooks with the correct names and they are password protected with the correct password, but the workbooks that were created were blank. They did not contain the data that was in each of the worksheets of the same names. I've included an image of the 'master workbook' and one of the worksheets to be exported.

 

[DanteAmor]

There was an error when copying the sheet; and since the On Error Resume Next instruction is present, you cannot see what the error is, that is why it is not convenient to put that instruction, as far as possible you should control possible errors with code.

Try this:

Sub SaveSheets()
  Dim worksheet_list As Range
  Dim new_workbook As Workbook
  Dim saved_folder As String
  Dim worksheet_name As Range
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  saved_folder = "C:\Users\warleque\OneDrive - Confluent Health\Desktop\TestExcel\"
  
  Set worksheet_list = ThisWorkbook.Sheets("Setup").Range("B2:B4")
  
  For Each worksheet_name In worksheet_list
    
    Sheets(worksheet_name.Value).Copy
    Set new_workbook = ActiveWorkbook
    new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51, Password:=worksheet_name.Offset(0, 1)
    new_workbook.Close False
  
  Next worksheet_name
  
  MsgBox "Export complete", vbInformation

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[warleque]

There was an error when copying the sheet; and since the On Error Resume Next instruction is present, you cannot see what the error is, that is why it is not convenient to put that instruction, as far as possible you should control possible errors with code.

Try this:

Sub SaveSheets()
  Dim worksheet_list As Range
  Dim new_workbook As Workbook
  Dim saved_folder As String
  Dim worksheet_name As Range
 
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
 
  saved_folder = "C:\Users\warleque\OneDrive - Confluent Health\Desktop\TestExcel\"
 
  Set worksheet_list = ThisWorkbook.Sheets("Setup").Range("B2:B4")
 
  For Each worksheet_name In worksheet_list
   
    Sheets(worksheet_name.Value).Copy
    Set new_workbook = ActiveWorkbook
    new_workbook.SaveAs saved_folder & worksheet_name & ".xlsx", 51, Password:=worksheet_name.Offset(0, 1)
    new_workbook.Close False
 
  Next worksheet_name
 
  MsgBox "Export complete", vbInformation

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

Thank you, this now works.

I have a follow up question:
1. If I wanted to export more than one sheet to the same workbook file name, Say zRed and zYellow to a workbook called zOrange. Is there an easy way to add that to this code? I would creage a new column on the setup tab that would contain the workbook name that the worksheets would be exported to and just repeat the workbook name as necessary:

 

[warleque]

Thank you, this now works.

I have a follow up question:
1. If I wanted to export more than one sheet to the same workbook file name, Say zRed and zYellow to a workbook called zOrange. Is there an easy way to add that to this code? I would creage a new column on the setup tab that would contain the workbook name that the worksheets would be exported to and just repeat the workbook name as necessary:

Also, would it be possible to also include the same worksheet in multiple workbooks, see attached:

 

[DanteAmor]

Also, would it be possible to also include the same worksheet in multiple workbooks, see attached:

Try:

Sub SaveSheets_v2()
  Dim worksheet_list As Range
  Dim new_workbook As Workbook
  Dim saved_folder As String, nm As String, bk As String, pw As String
  Dim worksheet_name As Range
  Dim dic As Object
  Dim ky As Variant, ary As Variant
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  saved_folder = "C:\Users\warleque\OneDrive - Confluent Health\Desktop\TestExcel\"
  
  Set worksheet_list = ThisWorkbook.Sheets("Setup").Range("B2:B5")
  Set dic = CreateObject("Scripting.Dictionary")
  
  For Each worksheet_name In worksheet_list
    nm = worksheet_name.Value
    bk = worksheet_name.Offset(0, 1).Value & "|" & worksheet_name.Offset(0, 2).Value
    If Not dic.exists(bk) Then
      dic(bk) = nm
    Else
      dic(bk) = dic(bk) & "," & nm
    End If
  Next
  
  For Each ky In dic.keys
    ary = Split(dic(ky), ",")
    Sheets(ary).Copy
    Set new_workbook = ActiveWorkbook
    bk = Split(ky, "|")(0)
    pw = Split(ky, "|")(1)
    new_workbook.SaveAs saved_folder & bk & ".xlsx", 51, Password:=pw
    new_workbook.Close False
  Next
  
  MsgBox "Export complete", vbInformation

  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
End Sub

 

[warleque]

Thanks, I changed my if statement to root out blanks... in the rngcell area... if rngCell.offset(0, 4) = "" Then GoTo SkipTo. The GoTo SkipTo is just above the next rngCell