macros循环复制粘贴挂起

有人可以帮助我这个循环macros吗？ 我想循环复制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