选择多个范围并一次粘贴一个答案

【问题标题】：Select multiple ranges and paste one at time选择多个范围并一次粘贴一个
【发布时间】：2020-07-14 11:39:50
【问题描述】：

我真的是 VBA 的初学者，我正在尝试复制一系列范围，并且需要一次粘贴一个（到偏移行工作）。

这张图片是我所拥有的：

而这张图片正是我想要的：

要做到这一点，我只考虑基于范围的复制，仅奇数范围并粘贴到“F”列中，仅复制偶数范围并粘贴到“N”列中。

目前，我有这个代码。我工作得很好，但我有 20 个奇数范围和 20 个偶数范围。我需要一个简单的方法来放这 20 次重复

        Range("A3:G7").Copy
        Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=1).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

        Range("A15:G19").Copy
        Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

        Range("A27:G31").Copy
        Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll
        Application.CutCopyMode = False

一起（这里我只展示了 3 次重复的代码）。

    Dim ws As Worksheet

    Application.ScreenUpdating = False
    Sheets("Car").Activate
    Range("F2:AA250").Delete
    Sheets("Summary").Activate

            Range("A3:G7").Copy
            Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=1).PasteSpecial xlPasteAll
            Application.CutCopyMode = False

            Range("A15:G19").Copy
            Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll
            Application.CutCopyMode = False

            Range("A27:G31").Copy
            Worksheets("Car").Cells(Rows.Count, "F").End(xlUp).Offset(RowOffset:=2).PasteSpecial xlPasteAll

            Application.CutCopyMode = False
            Range("F2").Activate
    Application.ScreenUpdating = True
End Sub

【问题讨论】：

不要重复代码 20 次（这是一个不好的做法）。改用循环：For i = 1 To 20 并使用 Range.Offset property 从您的第一个范围偏移到其他范围。
如果xlPasteAll，为什么是PasteSpecial 而不是Paste？范围是相同的。您必须复制它并在简单的迭代中更改数字...

标签： excel vba range paste

【解决方案1】：

试试这个。我还没有测试过，所以如果它第一次工作会很惊讶！

它确实依赖于右上角的单元格中有一些东西。如果没有，循环将停止。如果您事先知道需要多少份副本，则 For-Next 循环会更好。

Sub x()

Dim r As Range, n As Long: n = 1

With Worksheets("Summary")
    Set r = .Range("A3:G7")
    Do Until IsEmpty(r.Cells(1, r.Columns.Count))
        r.Copy Worksheets("Car").Range("F" & n)
        r.Offset(r.Rows.Count + 1).Copy Worksheets("Car").Range("N" & n)
        Set r = r.Offset((r.Rows.Count + 1) * 2)
        n = n + r.Rows.Count + 1
    Loop
End With

End Sub

【讨论】：

【解决方案2】：

请试试这个简单的方法。只有你的第一个范围就足够了。代码可以根据迭代次数（奇数或偶数）将范围复制到适当的位置。您可以进行更多迭代，只需更改迭代次数 (howMany)：

Sub CopyRange_()
Dim sh As Worksheet, nextRow As Long, howMany As Long
Dim rng As Range, i As Long, No As Long
Set sh = ActiveSheet
Set rng = sh.Range("A3:L8"): nextRow = rng.Cells(1, 1).Row
No = 2: howMany = 20
rng.Copy

 For i = 1 To howMany - 1
    If i Mod 2 = 0 Then
        sh.Range("A" & nextRow).Select: sh.Paste
        sh.Range("L" & nextRow).value = No: No = No + 1
    Else
        sh.Range("N" & nextRow).Select: sh.Paste
        sh.Range("Y" & nextRow).value = No: No = No + 1
        nextRow = nextRow + rng.Rows.Count
    End If
 Next i
End Sub

如果您需要更多行，选择适当的范围就足够了，而不是“A3:L8”。比如“A3:L10”……

【讨论】：