Copy multiple specific sheets to new workbook

Export Multiple Worksheets

Simple

Assumptions

• The source workbook is the workbook containing this code (ThisWorkbook). If it is not, then reference it by using its name, e.g.

  Set swb = Workbooks("Source.xlsx")
  

  Only if you don't know its name, make sure that it is active ('selected') and use

  Set swb = ActiveWorkbook
  

• The strings in the list (array) are the names of existing worksheets to be copied. If a sheet doesn't exist or is a chart, the line swb.Worksheets(sWorkSheetNames).Copy will throw an error.

• At least one of the worksheets is visible. If not, again, the line swb.Worksheets(sWorkSheetNames).Copy will throw an error.

Issues

• Very hidden worksheets will not be copied.
• The order of the copied worksheets in the destination workbook will be the same as their order in the source workbook, which may be different than their order in the list (array).

(Not) Avoiding Errors

• If you want to avoid the aforementioned errors stopping the program, you need to do it properly. If you put On Error Resume Next (don't use it until you fully understand what it does) before this code then you have made a fatal mistake. If an error occurs in the aforementioned line, the program will not stop but will continue, incorrectly referencing the last workbook (Set dwb = Workbooks(Workbooks.Count)) which may be the source workbook, and do damage to it. For further detail, see the investigative version of the code at the bottom of this post.

Sub ExportWorksheets()

    ' Source
    
    Dim sWorkSheetNames() As Variant
    sWorkSheetNames = Array("Daily Summary", "Daily Report")
    
    ' Reference the source workbook ('swb').
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code

    ' Copy the worksheets to a new workbook.
    swb.Worksheets(sWorkSheetNames).Copy
    
    ' Destination
    
    ' Reference this new workbook, the destination workbook ('dwb').
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    
    Dim dws As Worksheet
    Dim drg As Range
    
    ' Convert formulas to values.
    For Each dws In dwb.Worksheets
        Set drg = dws.UsedRange
        drg.Value = drg.Value
    Next dws

    ' Continue to save the destination workbook...

    dwb.Saved = True ' just for easy closing while testing this code

End Sub

Investigative

Sub ExportWorksheets()

    Const AssumeListPositions As Boolean = True

    ' Source
    
    Dim sSheetNames() As Variant
    sSheetNames = VBA.Array("Daily Summary", "Daily Report")
    
    ' Reference the source workbook ('swb').
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code

    ' Validate the list.
    
    ' Conditions
    '     All sheets from the list need to exist.
    '     All sheets need to be worksheets.
    '     A very hidden worksheet cannot be copied.
    '     At least one worksheet needs to be visible.

    ' Attempt to reference the sheets collection.
    On Error Resume Next
        Dim sshs As Sheets: Set sshs = swb.Sheets(sSheetNames)
    On Error GoTo 0
    If sshs Is Nothing Then
        MsgBox "A sheet does not exist.", vbCritical
        Exit Sub
    End If
    
    Dim ssh As Object
    Dim VisibleFound As Boolean
    
    For Each ssh In sshs
        If ssh.Type <> xlWorksheet Then
            MsgBox "The sheet '" & ssh.Name & "' is not a worksheet.", _
                vbCritical
            Exit Sub
        End If
        If ssh.Visible = xlSheetVeryHidden Then
            MsgBox "The worksheet '" & ssh.Name & "' is very hidden.", _
                vbCritical
            Exit Sub
        End If
        If Not VisibleFound Then
            If ssh.Visible = xlSheetVisible Then VisibleFound = True
        End If
    Next ssh
    
    If Not VisibleFound Then
        MsgBox "No visible worksheet found.", vbCritical
        Exit Sub
    End If
        
    ' Copy the worksheets to a new workbook.
    sshs.Copy
    
    ' Destination
    
    ' Reference this new workbook, the destination workbook ('dwb').
    Dim dwb As Workbook: Set dwb = Workbooks(Workbooks.Count)
    
    Dim dws As Worksheet
    Dim drg As Range
    
    ' Convert formulas to values.
    For Each dws In dwb.Worksheets
        Set drg = dws.UsedRange
        drg.Value = drg.Value
    Next dws

    If AssumeListPositions Then
        Dim dIndex As Long
        For dIndex = 0 To UBound(sSheetNames) - 1
            Set dws = dwb.Worksheets(sSheetNames(dIndex))
            If dws.Index > dIndex + 1 Then
                dws.Move Before:=dwb.Worksheets(dIndex + 1)
            End If
        Next dIndex
    End If
    
    ' Continue to save the destination workbook...

    dwb.Saved = True ' just for easy closing while testing the code

End Sub