excel - 复制粘贴的宏循环挂起

Question

有人可以帮我处理这个循环宏吗？我希望循环复制Range("S16:Y16").Select 向下移动三行并粘贴它，然后向下移动三行并重复直到达到 20。

错误是它下降了三行然后挂起。任何帮助，将不胜感激

示例代码

Sub pop1()
    '  Macro
    '
    ' Keyboard Shortcut: Ctrl+f
    '
    Range("S16:Y16").Select
    Selection.Copy
    Range("S19").Select
    ActiveSheet.Paste

    Range("s19:Y19").Select

    For i = 1 To 20
        Selection.Copy
        Range("s19").Offset(3, 0).Select
        ActiveSheet.Paste

        ActiveCell.Offset(3, 0).Select
        ActiveSheet.Paste
    Next i
End Sub

Answer 1

如果你想在第 19 行之后粘贴 20 次，那么试试这个

Sub pop1()
    Dim ws As Worksheet
    Dim r As Long

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        r = 19

        For i = 1 To 21
            .Range("S16:Y16").Copy .Range("S" & r)
            r = r + 3
        Next i
    End With
End Sub

编辑

以上将粘贴值，如果您想以所有格式粘贴它，请执行此操作

Sub pop1()
    Dim ws As Worksheet
    Dim r As Long

    '~~> Change this to the relevant sheet
    Set ws = ThisWorkbook.Sheets("Sheet1")

    With ws
        r = 19

        For i = 1 To 21
            .Range("S16:Y16").Copy
            .Range("S" & r).PasteSpecial xlPasteAll
            r = r + 3
        Next i
    End With
End Sub

Answer 2

仅当您没有想要保留的值低于它时，为什么不切断循环，否则已经提供了其他答案：

Dim r As Range
Set r = Range("S16:Y16").resize(3)'changed range to include 2 rows bellow 

r(1,1).Offset(R.count, 0).resize(R.count*20).value = R.value

请原谅我在手机上的任何语法错误。如果您发现错误，我很乐意修复。

Answer 3

你能试试这个吗？

Sub pop1()
    '  Macro
    '
    ' Keyboard Shortcut: Ctrl+f
    '
    Dim r As Range
    Set r = Range("S16:Y16")
    r.Copy  

    For i = 1 To 20
        r.Offset(3 * i, 0).PasteSpecial
     Next i
End Sub

或者这个极简主义者：

Sub pop1()
    '  Macro
    '
    ' Keyboard Shortcut: Ctrl+f

  Range("S16:Y16").Copy

    For i = 1 To 20
        Range("S16:Y16").Offset(3 * i, 0).PasteSpecial
    Next i
End Sub

Answer 4

试试下面的代码：

Sub pop1()
    '  Macro
    '
    ' Keyboard Shortcut: Ctrl+f
    '
    Dim rng As Range
    Set rng = Range("S16:Y16")

    j = 16
    For i = 1 To 20
        j = j + 3
         rng.Copy Range("S" & j)
    Next
End Sub