复制工作表错误：复制区域和粘贴区域大小不同

Question

我创建了代码以使用循环复制第一个名为“All-PID”的工作表上的所有 25 个动态工作表。

我之前能够运行很长的代码，现在卡在一条错误消息上。

Sub Consolidation()
    
    'Create All-PID Worksheet
    
    Sheets("PMCC-1").Select
    Sheets("PMCC-1").Copy Before:=Sheets(1)
    Sheets("PMCC-1 (2)").Select
    Sheets("PMCC-1 (2)").Name = "All-PID"
    
    Application.ScreenUpdating = False
    
    'Copy PMCC-2 upto PMCC-25 to "All-PID" Worksheet
    
    Dim ws As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets 
        If ws.Name <> "PMCC-1" Then 
            Dim s1 As Excel.Worksheet
            Dim s2 As Excel.Worksheet
            Dim iLastCellS1 As Excel.Range
            Dim iLastRowS2 As Long
    
            Set s1 = Sheets("All-PID")
            Set s2 = ActiveSheet
    
            iLastRowS2 = s2.Cells(s2.Rows.Count, "A").End(xlUp).Row
            Set iLastCellS1 = s1.Cells(s1.Rows.Count, "A").End(xlUp).Offset(1, 0)
            s2.Range("A2", s2.Cells(iLastRowS2, "W")).Copy iLastCellS1
        End If
    Next ws
End Sub

似乎卡在s2.Range("A2", s2.Cells(iLastRowS2, "W")).Copy iLastCellS1。

错误信息是

运行时错误“1004”
"这里不能粘贴，因为没有复制区和粘贴区
大小一样”。

Answer 1

两个工作表（“All-PID”和“PMCC-1”）应该从循环中排除，因为“PMCC-1”的内容已经在“All-PID”表中。

Option Explicit
Sub Consolidation()
    
    Worksheets("PMCC-1").Copy Before:=Sheets(1)
    Sheets("PMCC-1 (2)").Select
    Sheets("PMCC-1 (2)").Name = "All-PID"

    Application.ScreenUpdating = False
 
    Dim wsDest As Excel.Worksheet
    Dim ws As Excel.Worksheet
               
    Set wsDest = Sheets("All-PID")
    Set ws = ActiveSheet
    
    For Each ws In ActiveWorkbook.Worksheets
        Select Case ws.Name
        Case Is = "All-PID", "PMCC-1"
        Case Else
            Dim iLastRowS2 As Long
            iLastRowS2 = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
            Dim iLastCellS1 As Excel.Range
            Set iLastCellS1 = wsDest.Cells(wsDest.Rows.Count, A").End(xlUp).Offset(1,0)
            ws.Range("A2", ws.Cells(iLastRowS2, "W")).Copy iLastCellS1

        End Select
            
    Next ws

End Sub

Answer 2

我已将您的代码重构为应该可以工作且更可持续的代码。我已经评论了一些我修改过的 VBA Excel 编码原则。

Option Explicit

Sub Consolidation()

    Application.ScreenUpdating = False

    'Create All-PID Worksheet
    '**** - Work directly with object ***
    Worksheets("PMCC-1").Copy Before:=Sheets(1)

    Dim pmcc As Worksheet
    Set pmcc = ActiveSheet
    pmcc.Name = "All-PID"

    'Copy PMCC-2 upto PMCC-25 to "All-PID" Worksheet
    Dim ws As Worksheet

    For Each ws In ThisWorkbook.Worksheets

        If ws.Name <> pmcc.Name Then

            With ws '**** - No need to recreate variables ... also with block can make code easier to read and write and understand***

                Dim lastRow As Long
                lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

                Dim copyRange As Range
                Set copyRange = .Range("A2:W" & lastRow)

            End With

            With pmcc '**** - resize is VERY useful. I assume you don't need formulas copied, if so, i can edit answer
                .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(copyRange.Rows.Count, copyRange.Columns.Count).Value = copyRange.Value
            End With

        End If

    Next ws

End Sub