Macro to copy/paste specific range every 3 rows [Solved/Closed]

Report
-
 Isa -
Hello,

I am beginner in VBA and now have an Excel sheet with about 4000 rows, where I could need a macro.

I already recorded a macro for the first rows, which looks as follow:

Sub Loop1()

Range("BG2:FJ2").Select
Selection.Cut
Range("E3").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll ToRight:=39
Range("BG3:DH3").Select
Selection.Cut
Range("E4").Select
ActiveSheet.Paste

Range("BG5:FJ5").Select
Selection.Cut
Range("E6").Select
ActiveSheet.Paste
ActiveWindow.SmallScroll ToRight:=39
Range("BG6:DH6").Select
Selection.Cut
Range("E7").Select
ActiveSheet.Paste

End Sub

'Or alternatively for the first row
Sub Loop2()

Sheets("Worksheet1").Range("BG2:FJ2").Cut Sheets("Worksheet1").Range("E3")
Sheets("Worksheet1").Range("BG3:DH3").Cut Sheets("Worksheet1").Range("E4")

End Sub


However, I do not know how to adjust it, so that Excel does the rest/loop until row 4000.

Any idea or help would be highly appreciated.

Thanks a lot in advance.

Best,
Isa

1 reply

Posts
2670
Registration date
Sunday September 12, 2010
Status
Moderator
Last seen
October 22, 2020
446
Hi Isa,

See if the following code works for you:
Sub RunMe()
Dim x As Integer
x = 2
Do
    Range(Cells(x, "BG"), Cells(x, "FJ")).Cut Sheets("Worksheet1").Cells(x + 1, "E")
    Range(Cells(x + 1, "BG"), Cells(x + 1, "DH")).Cut Sheets("Worksheet1").Cells(x + 2, "E")
    x = x + 3
Loop Until x > 4000
End Sub 


Best regards,
Trowa
1
Thank you

A few words of thanks would be greatly appreciated. Add comment

CCM 2942 users have said thank you to us this month

Thank you so much, Trowa! The code works perfectly.

You just saved my day! :))

Best regards,
Isa