copy more than one sheets using VBA macro

Question

i'm a beginner in VBA and i need to do the following. Starting from a workbook i should create another one without formulas and macro code.

I found some solutions and based on that i modeled my own code:

    Sub SaveValuesOnly()
Dim wsCopy As Worksheet, wsPaste As Worksheet
Dim wb As Workbook
Dim sFileName As String, sPath As String


    sPath = "C:\Users\"
    sFileName = "OVERALL RECAP"
    Set wsCopy = ThisWorkbook.Worksheets("INCIDENTS")
    Set wb = Workbooks.Add
    Set wsPaste = wb.Sheets(1)
    
    
    wsCopy.Cells.copy
    wsPaste.Cells.PasteSpecial xlPasteValues
    wsPaste.Cells.PasteSpecial xlPasteFormats
    Application.CutCopyMode = False
      
    
    wsPaste.Name = "Expenses" 'Change if needed
    wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
    
End Sub

I need to copy more than one sheet and tried to use the official documentation like:

Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Copy
  With ActiveWorkbook
 .SaveAs Filename:=Environ("TEMP") & "\New3.xlsx", FileFormat:=xlOpenXMLWorkbook 
 .Close SaveChanges:=False 
 End With 

But i didn't manage to implement this into the code above, any suggestion? Thanks.

Answer 1

The code below takes the opposite approach to the earlier one. It copies the entire workbook to a new name and then modifies it. You can list the sheets you want to keep. Formulas in them will be converted to their values. Sheets not listed will be deleted.

Sub SaveValuesOnly()
    ' 154

    ' list the sheets you want to keep by their tab names
    Const SheetsToKeep  As String = "Sheet1,Sheet3"
    
    Dim sFileName       As String
    Dim sPath           As String
    Dim Wb              As Workbook             ' the new workbook
    Dim Ws              As Worksheet            ' looping object: worksheet
    Dim Keep()          As String               ' array of SheetsToKeep
    Dim i               As Long                 ' loop counter: Keep index
    
    sPath = Environ("UserProfile") & "\Desktop\"
    sFileName = "OVERALL RECAP"
    Keep = Split(SheetsToKeep, ",")
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    ' create a copy of the ActiveWorkbook under a new name
    ActiveWorkbook.SaveCopyAs sPath & sFileName & ".xlsm"
    Set Wb = Workbooks.Open(sPath & sFileName & ".xlsm")
    
    For Each Ws In Wb.Worksheets
        ' check if the sheet is to be kept
        For i = UBound(Keep) To 0 Step -1
            If StrComp(Ws.Name, Trim(Keep(i)), vbTextCompare) = 0 _
               Then Exit For
        Next i
        If i = True Then                        ' True = -1
            Ws.Delete
        Else
            ' keep the sheet
            With Ws.UsedRange
                .Copy
                .PasteSpecial xlPasteValuesAndNumberFormats
                ' you can repeat PasteSpecial here to copy more detail
            End With
        End If
    Next Ws

    ' change the file format to xlsx (deleting copy of this code in it)
    Wb.SaveAs Filename:=sPath & sFileName, FileFormat:=xlOpenXMLWorkbook
    Kill sPath & sFileName & ".xlsm"
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

There are a few points you need to be aware of. One, the ActiveWorkbook will be copied. That is presumed to the ThisWorkbook (the one containing the code) but it could be any other. Two, any workbook by the targeted name already existing at the location specified by sPath will be over-written without warning. Three, alerts are turned off while the code runs. If it happens to crash they will remain turned off until you restart Excel or enter Application.DisplayAlerts = True [Enter] in the Immediate window.

Last, but not least, sheets are processed in sequence of their index numbers (left to right). If your formulas in the kept sheets refer to data in sheets that get deleted the sequence is important. You may have to run two loops instead of the one my code has. Use one loop to replace formulas and another just to delete.

Answer 2

Copy Worksheets to New Workbook

The Flow

Basically, the procedure will:

• create a copy of ThisWorkbook (the workbook containing this code) in the destination folder,
• open the copy and continue to work with it,
• copy values to (remove formulas from) the specified worksheets,
• delete the not specified sheets,
• rename the specified worksheets,
• save the copy to a new workbook in .xlsx format,
• delete the copy.

Remarks

• If a workbook with the same name (e.g. OVERALL RECAP) is already open, it will crash Excel.
• Be careful when determining the worksheet names, because if you try to rename a worksheet using an already existing name, an error will occur.

The Code

Option Explicit

Sub copyWorksheets()
    
    Const dPath As String = "C:\Users"
    Const dFileName As String = "OVERALL RECAP"
    Const CopyList As String = "INCIDENTS,Sheet2,Sheet3"
    Const PasteList As String = "Expenses,Sheet2,Sheet4"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim CopyNames() As String: CopyNames = Split(CopyList, ",")
    Dim PasteNames() As String: PasteNames = Split(PasteList, ",")
    Dim nUpper As Long: nUpper = UBound(CopyNames)
    Dim tFilePath As String: tFilePath = dPath & "\" & "t_" & wb.Name
    
    Application.ScreenUpdating = False
    
    ' Save a copy.
    wb.SaveCopyAs tFilePath
    
    ' Work with the copy.
    With Workbooks.Open(tFilePath)
        ' Copy values (remove formulas).
        Dim n As Long
        For n = 0 To nUpper
            With .Worksheets(CopyNames(n)).UsedRange
                .Value = .Value
            End With
        Next n
        ' Delete other sheets.
        Dim dCount As Long: dCount = .Sheets.Count - nUpper - 1
        If dCount > 0 Then
            Dim DeleteNames() As String: ReDim DeleteNames(1 To dCount)
            Dim sh As Object ' There maybe e.g. charts.
            n = 0
            For Each sh In .Sheets
                If IsError(Application.Match(sh.Name, CopyNames, 0)) Then
                    n = n + 1
                    DeleteNames(n) = sh.Name
                End If
            Next sh
            Application.DisplayAlerts = False
            .Sheets(DeleteNames).Delete
            Application.DisplayAlerts = True
        End If
        ' Rename worksheets.
        For n = 0 To nUpper
            If CopyNames(n) <> PasteNames(n) Then
                .Worksheets(CopyNames(n)).Name = PasteNames(n)
            End If
        Next n
        ' Save workbook.
        .Worksheets(1).Activate
        Application.DisplayAlerts = False
        .SaveAs _
            Filename:=dPath & "\" & dFileName, _
            FileFormat:=xlOpenXMLWorkbook
        Application.DisplayAlerts = True
        '.Close SaveChanges:=False ' Close the new workbook.
    End With
  
    ' Delete the copy.
    Kill tFilePath
    
    Application.ScreenUpdating = True
    
    MsgBox "Workbook created.", vbInformation, "Success"
    
    'wb.Close SaveChanges:=False ' Close ThisWorkbook.

End Sub