How to loop a macro

[rlcurlee]

I have a macro that copies cells to another sheet and puts cells in order. I need to make this marco loop until there are no more rows to copy. This macro was recorded. I'm not good at writing macro from scratch.

I can't download the XL2BB so I hope you can us my macro.

Sub COPY_MOC()
'
' COPY_MOC Macro
'
' Keyboard Shortcut: Ctrl+Shift+Q
'
    Range("A2").Select
    Sheets("Sheet1").Select
    Range("B2:B5").Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("E2").Select
    Sheets("Sheet1").Select
    Range("D2:D5").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet2").Select
    Range("E2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Rows("2:2").Select
    Application.CutCopyMode = False
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A2").Select
    Sheets("Sheet1").Select
    Rows("1:5").Select
    Selection.Delete Shift:=xlUp
    Sheets("Sheet2").Select
    Range("A2").Select
End Sub

 

[dermie_72]

See if this works for you.

Sub rlcurlee()
Dim LR As Long
LR = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
Sheets("Sheet1").Activate
Range("A2").Select
Do While ActiveCell <> ""
    Range("B2:B5").Copy
    Sheets("Sheet2").Range("A" & LR).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("D2:D5").Copy
    Sheets("Sheet2").Range("E" & LR).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    ''Rows("2:2").Select
    Application.CutCopyMode = False
    Rows("1:5").Delete Shift:=xlUp
    LR = LR + 1
Loop
End Sub

 

[rlcurlee]

That worked great. Thank you so much.