Excel VBA 将指定的一组工作表复制到新工作簿/从副本中排除工作表

Question

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?

Answer 1

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

Answer 2

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