Question

首先我要说的是，我对实际编程的VB代码一无所知，我试图用Excel 2010中的工作簿帮助朋友。我做了一些谷歌搜索并找到了我认为可能有用的东西对于他们来说，似乎并没有抓住所有内容并将其粘贴到摘要表中，就像我想要的那样。

我想要的是从每个工作表中获取一系列单元格，将其复制并将其传递到摘要表中，当它将我希望它的数据粘贴到第2页的范围之外时，向下移动一行与表3相同的范围，等等，而不是将所有数据合并到相同的单元格中，就像它现在似乎正在做的那样。

这是我目前正在使用的代码，当我使用它时，接缝只能抓取最后一张纸张数据，然后通过前面纸张的顶部，而不是粘贴然后向下移动，然后粘贴下一张数据。

感谢您的帮助！

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

' Delete the summary sheet if it exists.
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Summary Sheet").Delete
On Error GoTo 0
Application.DisplayAlerts = True

' Add a new summary worksheet.
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary Sheet"

' Loop through all worksheets and copy the data to the
' summary worksheet.
For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then

        ' Find the last row with data on the summary worksheet.
        Last = 0

        ' Specify the range to place the data.
        Set CopyRng = sh.UsedRange

        ' Test to see whether there are enough rows in the summary
        ' worksheet to copy all the data.
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the " & _
               "summary worksheet to place the data."
            GoTo ExitTheSub
        End If

        ' This statement copies values and formats from each
        ' worksheet.
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "A")
            .PasteSpecial xlPasteValues
            .PasteSpecial xlPasteFormats
            Application.CutCopyMode = True
        End With

        ' Optional: This statement will copy the sheet
        ' name in the H column.
        'DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name

    End If
Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

' AutoFit the column width in the summary sheet.
DestSh.Columns.AutoFit

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

Answer 1

由于

，您的粘贴会在每次传递时恢复为第1行

Last = 0

对于重叠数据，请尝试以下更改

' Find the last row with data on the summary worksheet.
Last = DestSh.Rows.Count + 1

如何将多个工作表复制到摘要页面但不合并数据。

1 个答案: