Excel VBA copying specified set of worksheets to new workbook/excluding sheet from copy-CodePudding

I am trying to copy only data from one workbook into a new one, but with only four of the existing worksheets. The code below allows me to successfully copy all worksheets to a new workbook. This worked fine before, but now I only want to copy sheet 2-7, thus excluding sheet 1.

This is done by a user copying data into sheet 1 and the data will be populated to sheets 2-5. Sheet 6 & 7 contains metadata which will be the same for all new workbooks. To be able to import the copied data, I need a new workbook with sheets 2-7.

Sub Button1_Click()

Dim Output As Workbook
Dim Current As String
Dim FileName As String


Set Output = ThisWorkbook
Current = ThisWorkbook.FullName

Application.DisplayAlerts = False

Dim SH As Worksheet
For Each SH In Output.Worksheets
    SH.UsedRange.Copy
    SH.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats, _
        Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Next
    
FileName = ThisWorkbook.Path & "\" & "Generic name.xlsx" 'Change name as needed
Output.SaveAs FileName, XlFileFormat.xlOpenXMLWorkbook
Workbooks.Open Current
Output.Close
Application.DisplayAlerts = True

End Sub

Any suggestions on how improve the code to only copy specified sheets, or to exclude sheet 1?

CodePudding user response：

Add an IF statement after the For each loop to exclude Sheet1

For Each SH In Output.Worksheets
If SH.Name <> "Sheet1" Then
    SH.UsedRange.Copy
    SH.UsedRange.PasteSpecial xlPasteValuesAndNumberFormats, _
    Operation:=xlNone, SkipBlanks:=True, Transpose:=False
End If
Next

CodePudding user response：

Copy a Set of Worksheets to Another Workbook

Option Explicit

Sub Button1_Click()
    
    ' Constants
    
    Const dFileName As String = "Generic name.xlsx"
    Dim DoNotCopy As Variant: DoNotCopy = Array(1) ' add more: Array(1, 7, 8)
    Const ConversionWorksheetsCount As Long = 4
    
    ' Write the names of the desired worksheets to an array.
    
    Dim swb As Workbook: Set swb = ThisWorkbook
    Dim swsCount As Long: swsCount = swb.Worksheets.Count
    Dim dwsNames() As String: ReDim dwsNames(1 To swsCount)
    
    Dim sws As Worksheet
    Dim sCount As Long
    Dim dCount As Long
    
    For Each sws In swb.Worksheets
        sCount = sCount   1
        If IsError(Application.Match(sCount, DoNotCopy, 0)) Then
            dCount = dCount   1
            dwsNames(dCount) = sws.Name
        ' Else ' worksheet index found in the 'DoNotCopy' array.
        End If
    Next sws
    If dCount = 0 Then
        MsgBox "No worksheets found.", vbCritical
        Exit Sub
    End If
    
    If dCount < swsCount Then
        ReDim Preserve dwsNames(1 To dCount)
    End If
    
    Application.ScreenUpdating = False
    
    ' Copy the desired worksheets to a new (destination) workbook.
    
    swb.Worksheets(dwsNames).Copy
    Dim dwb As Workbook: Set dwb = ActiveWorkbook
    
    ' Do the conversions.
    
    Dim dws As Worksheet
    Dim n As Long
    
    For n = 1 To ConversionWorksheetsCount
        On Error Resume Next
            Set dws = dwb.Worksheets(n)
        On Error GoTo 0
        If Not dws Is Nothing Then ' destination worksheet exists
            dws.Activate ' needed for '.Cells(1).Select'
            With dws.UsedRange
                .Copy
                .PasteSpecial xlPasteValuesAndNumberFormats, _
                    Operation:=xlNone, SkipBlanks:=True, Transpose:=False
                .Cells(1).Select ' cosmetics
            End With
        'Else ' destination worksheet doesn't exist
        End If
    Next n
    'dwb.Worksheets(1).Activate ' cosmetics        

    ' Save the new (destination) workbook.
    
    Dim dFilePath As String: dFilePath = swb.Path & "\" & dFileName
    Application.DisplayAlerts = False ' overwrite without confirmation
    dwb.SaveAs dFilePath, xlOpenXMLWorkbook
    Application.DisplayAlerts = True
    dwb.Close
    
    ' Note that you never modified the source. It's in the same state as before.
    
    Application.ScreenUpdating = True
    
    MsgBox "Workbook created.", vbInformation
    
End Sub