Copy multiple specific sheets to new workbook

Question

I am using some legacy code to copy one specific worksheet (Daily Summary) to a new workbook and then replace all formulas with their actual values. This works fine for one sheet, but the code breaks once I try to set a foreach for a specified worksheet array with the sheet names ("Daily Summary","Daily Report"). Is there any specific syntax for copying multiple sheets?

I did look at this SO article but am unable to run this code on Excel for MAC which sadly is required.

Fairly new to Excel VBA, appreciate any guidance on this topic. Thank you.

'Copy the sheet to a new workbook
Sheets("Daily Summary").Copy Before:=Sheets(1)

With ActiveSheet
    .Cells.Copy
    .Cells.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False

pctCompl = 10

ActiveSheet.Copy
Set Destwb = ActiveWorkbook



'Determine the Excel version and file extension/format
With Destwb
    If Val(Application.Version) < 12 Then
        'You use Excel 2000-2003
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        'You use Excel 2007-2010, we exit the sub when your answer is
        'NO in the security dialog that you only see  when you copy
        'an sheet from a xlsm file with macro's disabled.
        If Sourcewb.Name = .Name Then
            With Application
                .ScreenUpdating = True
                .EnableEvents = True
            End With
            MsgBox "Your answer is NO in the security dialog"
            Exit Sub
        Else
            Select Case Sourcewb.FileFormat
            Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If .HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                    'FileExtStr = ".pdf": FileFormatNum = 17
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56: FileExtStr = ".xls": FileFormatNum = 56
            Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End If
End With

pctCompl = 30

'Change all cells in the worksheet to values if you want
'With Destwb.Sheets(1).Range("A1:I50")
'    .Select
'    .Copy
'    .PasteSpecial xlPasteValues
'End With
'Application.CutCopyMode = False

Answer 1

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