Help with looping my macro

Hello, I need some help looping a macro. I specifically want it to move down one cell until it reaches the bottom of sheet 1.

This is the macro:

   Sheets("Sheet1").Select
    Range("B4:B7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("Sheet2").Select
    Range("B3").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range("B3:RC3") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet2").Sort
        .SetRange Range("B3:RC6")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("B8").Select
    ActiveCell.FormulaR1C1 = "=AVERAGE(R[-4]C:R[-2]C)"
    Range("B8").Select
    Selection.AutoFill Destination:=Range("B8:RC8"), Type:=xlFillDefault
    Range("B8:RC8").Select

Help is greatly appreciated!

All of it.

I want the next command to start with: Range ("B5:B8").Select ... etc, adding 1 to every row number in the macro.

Though I do not want the pasted data in sheet 2 to overwrite previous data. So I suppose the next "loop" would have to start at cell B9 in sheet 2.