макрос петля для копирования пасты зависает

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

Не могли бы вы попробовать это?

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 2

Если Вы хотите вставить в 20 раз после строки 19, то попробуйте этот

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 

EDIT

выше будет па значения т е, и если вы хотите, чтобы вставить его в любом формате, то сделать это

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 3

Try ниже код:

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 

Answer 4

Почему бы не вырезать петлю только если не имеют значения ниже него вы хотите сохранить в противном случае другой ответ уже предусмотрены:

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 

Пожалуйста, простите синтаксических ошибок, как я на моем мобильном телефоне. Я рад исправить, если вы найдете ошибки.