ExcelVBA將指定的一組作業表復制到新作業簿/從副本中排除作業表

我試圖僅將一個作業簿中的資料復制到一個新作業簿中，但只有四個現有作業表。下面的代碼允許我成功地將所有作業表復制到新作業簿。這以前作業得很好，但現在我只想復制第 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 的任何建議？

uj5u.com熱心網友回復：

將一組作業表復制到另一個作業簿

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

uj5u.com熱心網友回復：

If在For Each回圈后添加一條陳述句以排除 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

標籤：擅长 vba excel-365

上一篇：如何修復ExcelVBA中的運行時錯誤“91”？

下一篇：將公式復制到最后一行