宏循环复制粘贴挂起

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

或这个mininimalist：

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