Excel VBA 正在将指定的一组工作 sheet 从副本复制到新的 workbook/excluding sheet

Question

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

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

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

Answer 1

在 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

Answer 2

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

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

Excel VBA 正在将指定的一组工作 sheet 从副本复制到新的 workbook/excluding sheet

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

excel

vba

excel-365

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