Question

美好的一天！我在下面有这些代码，它给我一个错误“我们无法粘贴，因为复制区域和粘贴区域大小不同”..请帮助这些代码有什么问题...... :(

Option Explicit

Sub CopyRangeFromMultiWorksheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim CopyRng As Range

With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True


Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "RDBMergeSheet"

For Each sh In ActiveWorkbook.Worksheets

    If IsError(Application.Match(sh.Name, _
                                 Array(DestSh.Name, "Information"), 0)) Then

        Last = LastRow(DestSh)

        If sh.Name = "Sheet1" Then
            Set CopyRng = sh.Range("A:G")
        End If

        If sh.Name = "Sheet2" Then
            Set CopyRng = sh.Range("B:G")
        End If

        If sh.Name = "Sheet3" Then
            Set CopyRng = sh.Range("C:G")
        End If

        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = False
        End With

    End If
Next

 ExitTheSub:

Application.GoTo DestSh.Cells(1)

DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With
 End Sub

以下是我的功能

Option Explicit

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(what:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
On Error GoTo 0
End Function


Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(what:="*", _
                        After:=sh.Range("A1"), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
On Error GoTo 0
End Function

Answer 1

您的来源范围定义为Full Columns。因此，除了目标工作表第一行的某个位置外，您无法将它们粘贴到任何位置。

请记住，工作表中的行数是有限的：Excel 2007及更高版本中的1048576行（Excel 2003中的65536行）。因此，当您尝试将完整列粘贴到第一行中的某个位置时，该副本将超出目标中的最后一个可用行。

您可以做的只是获取源列的已使用部分，希望目标表中有空间。要执行此操作，请更改定义源范围的方式，以便仅使用已使用的部分。即：

Set CopyRng = sh.UsedRange.Columns("A:G")
'               ^^^^^^^^^^^^^^^^^^^

对于您设置CopyRng的所有情况都这样做。

或者，您可以使用与目标工作表相同的方式查找源工作表的上次使用的行和上次使用的列。此选项应更准确，更安全。

VBA - 复制区域和粘贴区域大小错误不一样？

1 个答案: