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

Question

我试图仅将数据从一个工作簿复制到一个新工作簿中，但只有四个现有工作表。下面的代码允许我成功地将所有工作表复制到新工作簿。这以前工作得很好，但现在我只想复制工作表 2-7，因此不包括工作表 1。

这是通过用户将数据复制到工作表 1 来完成的，数据将填充到工作表 2-5。工作表 6 和 7 包含所有新工作簿的元数据。为了能够导入复制的数据，我需要一个带有工作表 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

关于如何改进代码以仅复制指定的工作表或排除工作表 1 的任何建议？

Answer 1

将一组工作表复制到另一个工作簿

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
            Set dws = Nothing
        '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

Answer 2

在For Each 循环之后添加If 语句以排除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