复制多个范围选择

时间:2014-01-10 20:59:56

标签: vba excel-vba excel

我正在使用我在Google上找到的一些代码。我正在尝试在多张纸上复制数据,并将其粘贴到摘要表中。

我想将A23和H8:S8中的数据复制到摘要表上的空白行。 A23列位于A列中,H8:S23位于HS列中。

这是我所拥有的,虽然它不起作用。

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


    ' Set Summary Worksheet.
Set DestSh = ActiveWorkbook.Worksheets("Tab_Upload")

    ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each sh In ActiveWorkbook.Worksheets
        If LCase(Left(sh.Name, 1)) = "_" Then

            ' Find the last row with data on the summary worksheet.
            Last = ActiveSheet.[a65536].End(xlUp).Row

            ' Specify the range to place the data.
            Set CopyRng = sh.Range("H8:S8, A23")


            ' This statement copies values and formats from each
            ' worksheet.
            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)

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

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

1 个答案:

答案 0 :(得分:0)

我尝试设置它,当我只是手动选择并尝试复制两个范围时,我得到一个“该命令不能用于多个选择”。但是,如果两个或多个范围具有相同的列数,则没问题。我想这是因为它们的尺寸不同VBA不能很好地处理这些尺寸。尝试逐个进行,如下:

Option Explicit

Private Sub DoStuff()

Dim ws As Worksheet
Dim summary As Worksheet
Dim rng As Range

Set summary = ThisWorkbook.Sheets("Sheet4")

For Each ws In ThisWorkbook.Worksheets
    If ws.Name <> summary.Name Then
        ws.Range("A1").Copy summary.Range("A" & summary.Range("A" &    summary.Rows.Count).End(xlUp).Row + 1)
        ws.Range("C1:D4").Copy summary.Range("A" & summary.Range("A" & summary.Rows.Count).End(xlUp).Row + 1)
    End If
Next ws

End Sub

已编辑,如果复制多个范围,则必须具有相同的列数

相关问题