Copy multiple sheets to new workbook using dynamic array

[zmasterdevil]

Hello Everyone,

When I click a button on a sheet within my workbook, I want a macro to do the following:

1. Copy all the sheets named in cell “AA1” to a new workbook (I’m having trouble getting a dynamic array to work for this). If the array needs each sheet name in a different cell, I can put the sheet names in “AA1”, “AB1”, “AC1”, etc…
2. Then save the new workbook into the Documents folder using data from 2 cells on the active sheet (“Z2”, & “AA2”) to name the file. Cell “Z2” is the account number, and cell “AA2” is the month/year of the workbook in format “mmmm yyyy” (this is NOT the current month/year).
3. Then close the new workbook.

I am not sure if the array part is possible, or if there is another way to go about this. I am trying to create a code that will work for each group of worksheets that need to be saved together. But if a dynamic array or something similar won't work, I will make do with the rest of the code working, and I'll just hard code in the sheet names for each account grouping and make multiple modules to accomplish it (I'm trying to avoid making so many repetitive modules if possible).

I've put my code below. I keep getting a "Run-time Error '9': Subscript out of range" (I've attached a screenshot of where the debugger stops on the "Sheets(Array(Range("AA1").Value)).Copy" line. I've looked up a lot of information on arrays, but haven't found anything that works for what I'm trying to do.

I welcome any help, or suggestions of other ways to accomplish my aim if using an array for this won't work. Apologies for any coding blunders, I do not know much VBA code.

Sub Copy_Sheets_to_New_Workbook()

    Dim FilePath As String
    Dim FileExt As String
    Dim FileName As String
    Dim FileFullPath As String
    Dim FileFormat As Variant
    Dim wb1 As Workbook
    Dim wb2 As Workbook

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
            
    Set wb1 = ThisWorkbook
        Sheets(Array(Range("AA1").Value)).Copy
    Set wb2 = ActiveWorkbook
    
        'Below gets the File Extension and File Format
    With wb2
        If Val(Application.Version) < 12 Then
             FileExt = ".xls": FileFormat = -4143
        Else
            Select Case wb1.FileFormat
            Case 51: FileExt = ".xlsx": FileFormat = 51
            Case 52:
                If .HasVBProject Then
                    FileExt = ".xlsm": FileFormat = 52
                Else
                    FileExt = ".xlsx": FileFormat = 51
                End If
            Case 56: FileExt = ".xls": FileFormat = 56
            Case Else: FileExt = ".xlsb": FileFormat = 50
            End Select
        End If
    End With
    
        'Save workbook in Documents folder of your system
    FilePath = "C:\Users\JAMES\Documents"
    
        'Now append month/year to the filename
    FileName = Range("Z2").Value & " " & Range("AA2").Value  'Possibly change 2nd cell to: Format(Range("AA2").Value), "mmmm yyyy")
    
        'Complete path of the file where it is saved
    FileFullPath = FilePath & FileName & FileExt
    
        'Now save currect workbook at the above path
    wb2.SaveAs FileFullPath, FileFormat:=FileFormat
    
    wb2.Close SaveChanges:=True

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

 

[Herakles]

The spreadsheet names should be seperated by a comma.

No quotation marks are required.

This code version will check for these characters and abort the process if any are found.

It will also check to see if all of the worksheets stated in AA1 exist in the workbook.

All you have to do is change this line:

Make sure that you include the last "\" character.

strFolder = "C:\Users\JAMES\Documents\"

Public Sub subCopySheetsToNewWorkbookVersion2()
Dim Wb As Workbook
Dim WbActive As Workbook
Dim WsActive As Worksheet
Dim strMsg As String
Dim arrWorksheets() As String
Dim blnExists As Boolean
Dim i As Integer
Dim Ws As Worksheet
Dim strFolder As String
Dim strWorkbookName As String
Dim strWorksheets As String

On Error GoTo Err_Handler

    With Application
        .ScreenUpdating = False
    End With
   
    ActiveWorkbook.Save
   
    Set WbActive = ActiveWorkbook
   
    Set WsActive = Worksheets("Destination")
           
    WsActive.Activate
       
    strWorksheets = WsActive.Range("AA1")
    
    If Left(strWorksheets, 1) = "," Then
        strWorksheets = Mid(strWorksheets, 2, Len(strWorksheets) - 1)
    End If
    
    If Trim(Replace(strWorksheets, ",", "", 1)) = "" Then
        MsgBox "Cell AA1 is empty", vbInformation, "Warning!!"
        MsgBox "The process has been terminated.", vbInformation, "Warning!!"
        Exit Sub
    End If
    
    If InStr(1, strWorksheets, ",", vbTextCompare) = 0 Then
        MsgBox "The worksheet names in cell AA1 need to be seperated by commas.", vbInformation, "Warning!!"
        MsgBox "The process has been terminated.", vbInformation, "Warning!!"
        Exit Sub
    End If
    
    If InStr(1, strWorksheets, Chr(34), vbTextCompare) > 0 Then
        strMsg = "The AA1 value includes quotation marks." & vbCrLf
        strMsg = strMsg & "Remove the quotes and seperate the worksheet names with commas."
        MsgBox strMsg, vbInformation, "Warning!!"
        MsgBox "The process has been terminated.", vbInformation, "Warning!!"
        Exit Sub
    End If
        
    arrWorksheets = Split(strWorksheets, ",")
    For i = LBound(arrWorksheets) To UBound(arrWorksheets)
        blnExists = False
        For Each Ws In WbActive.Worksheets
            If Ws.Name = arrWorksheets(i) Then
                blnExists = True
            End If
        Next Ws
        If Not blnExists Then
            MsgBox "Worksheet '" & arrWorksheets(i) & "' does not exist in the workbook.", vbInformation, "Warning!!"
            MsgBox "The process has been terminated.", vbInformation, "Warning!!"
            Exit Sub
        End If
    Next i
    
    WbActive.Sheets(Split(strWorksheets, ",")).Copy
    
    strFolder = "C:\Users\JAMES\Documents\"
       
    strWorkbookName = WsActive.Range("Z2").Value & "-" & WsActive.Range("AA2").Value
    
    With ActiveWorkbook
        .SaveAs Filename:=strFolder & strWorkbookName, FileFormat:=WbActive.FileFormat
        strWorkbookName = ActiveWorkbook.FullName
        .Close
    End With
    
    MsgBox "Worksheets have been copied into a new workbook named : " & vbCrLf & vbCrLf & strWorkbookName, vbInformation, "Confirmation"

Exit_Handler:

    With Application
        .ScreenUpdating = True
    End With

    Exit Sub

Err_Handler:

    MsgBox "There has been an error in creating the new workbook.", vbInformation, "Warning!"
    
    MsgBox "The process has been terminated.", vbInformation, "Warning!"
        
    Resume Exit_Handler
    
End Sub

 

[zmasterdevil]

The spreadsheet names should be seperated by a comma.

No quotation marks are required.

This code version will check for these characters and abort the process if any are found.

It will also check to see if all of the worksheets stated in AA1 exist in the workbook.

All you have to do is change this line:

Make sure that you include the last "\" character.

strFolder = "C:\Users\JAMES\Documents\"

Public Sub subCopySheetsToNewWorkbookVersion2()
Dim Wb As Workbook
Dim WbActive As Workbook
Dim WsActive As Worksheet
Dim strMsg As String
Dim arrWorksheets() As String
Dim blnExists As Boolean
Dim i As Integer
Dim Ws As Worksheet
Dim strFolder As String
Dim strWorkbookName As String
Dim strWorksheets As String

On Error GoTo Err_Handler

    With Application
        .ScreenUpdating = False
    End With
  
    ActiveWorkbook.Save
  
    Set WbActive = ActiveWorkbook
  
    Set WsActive = Worksheets("Destination")
          
    WsActive.Activate
      
    strWorksheets = WsActive.Range("AA1")
   
    If Left(strWorksheets, 1) = "," Then
        strWorksheets = Mid(strWorksheets, 2, Len(strWorksheets) - 1)
    End If
   
    If Trim(Replace(strWorksheets, ",", "", 1)) = "" Then
        MsgBox "Cell AA1 is empty", vbInformation, "Warning!!"
        MsgBox "The process has been terminated.", vbInformation, "Warning!!"
        Exit Sub
    End If
   
    If InStr(1, strWorksheets, ",", vbTextCompare) = 0 Then
        MsgBox "The worksheet names in cell AA1 need to be seperated by commas.", vbInformation, "Warning!!"
        MsgBox "The process has been terminated.", vbInformation, "Warning!!"
        Exit Sub
    End If
   
    If InStr(1, strWorksheets, Chr(34), vbTextCompare) > 0 Then
        strMsg = "The AA1 value includes quotation marks." & vbCrLf
        strMsg = strMsg & "Remove the quotes and seperate the worksheet names with commas."
        MsgBox strMsg, vbInformation, "Warning!!"
        MsgBox "The process has been terminated.", vbInformation, "Warning!!"
        Exit Sub
    End If
       
    arrWorksheets = Split(strWorksheets, ",")
    For i = LBound(arrWorksheets) To UBound(arrWorksheets)
        blnExists = False
        For Each Ws In WbActive.Worksheets
            If Ws.Name = arrWorksheets(i) Then
                blnExists = True
            End If
        Next Ws
        If Not blnExists Then
            MsgBox "Worksheet '" & arrWorksheets(i) & "' does not exist in the workbook.", vbInformation, "Warning!!"
            MsgBox "The process has been terminated.", vbInformation, "Warning!!"
            Exit Sub
        End If
    Next i
   
    WbActive.Sheets(Split(strWorksheets, ",")).Copy
   
    strFolder = "C:\Users\JAMES\Documents\"
      
    strWorkbookName = WsActive.Range("Z2").Value & "-" & WsActive.Range("AA2").Value
   
    With ActiveWorkbook
        .SaveAs Filename:=strFolder & strWorkbookName, FileFormat:=WbActive.FileFormat
        strWorkbookName = ActiveWorkbook.FullName
        .Close
    End With
   
    MsgBox "Worksheets have been copied into a new workbook named : " & vbCrLf & vbCrLf & strWorkbookName, vbInformation, "Confirmation"

Exit_Handler:

    With Application
        .ScreenUpdating = True
    End With

    Exit Sub

Err_Handler:

    MsgBox "There has been an error in creating the new workbook.", vbInformation, "Warning!"
   
    MsgBox "The process has been terminated.", vbInformation, "Warning!"
       
    Resume Exit_Handler
   
End Sub

Hello Herakles,

After changing the line: strFolder = "C:\Users\JAMES\Documents\" to the correct filepath:

this time, it just gives me the error messages "There has been an error in creating the new workbook.", "The process has been terminated." And no workbook was created.

I did find that if I also changed the line:

Set WsActive = Worksheets("Destination")

and replaced "Destination" with the name of the active sheet "540006 Bernardo", it goes a little farther before failing. When I did this, it does actually create (but not save) the new workbook, names it "2023" (I'm not sure why, as cell "AA2" has both a month & year in it), then I get the same failure messages. After clicking OK on the failure messages, the new workbook is left open.

On the bright side, the workbook created is correct with all the needed sheets in it. But, as the debugger isn't available when using this code (I think because the error handler is being used), I can't tell exactly where it is failing. Any ideas of what I'm doing wrong?