Visual Basic para Aplicaciones - Problema para cambiar el valor de un rango en un ciclo

Sub RecorreOrdenaRango()

Dim rango As Range

Range("b1:c1").Name = "rango"

Range("rango").Select

'--> repetir hasta que la selección esté vacía

 Do Until ActiveCell.Value = ""

     '--> ordena las celdas seleccionadas horizontalmente

    ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("Hoja1").Sort.SortFields.Add2 Key:=Range("rango"), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("Hoja1").Sort

        .SetRange Range("rango")

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlLeftToRight

        .SortMethod = xlPinYin

        .Apply

    End With

    ==> ACÁ NECESITO QUE EL VALOR DE "rango" CAMBIE Y SEA IGUAL AL RANGO ORIGINAL

           PERO DESPLAZADO UNA FILA HACIA ABAJO

 Loop

End Sub

Sub RecorreOrdenaRango2()

Dim r As Range

Dim ws As Worksheet

Set ws = ActiveWorkbook.Worksheets("Hoja1")

Set r = Range("b1:c1")

r.Select

Do Until ActiveCell.Value = VBA.vbNullString

    With ws.Sort

        .SortFields.Clear

        .SortFields.Add2 Key:=r, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

        .SetRange r

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlLeftToRight

        .SortMethod = xlPinYin

        .Apply

    End With

    Set r = r.Offset(1)

    r.Select

 Loop

End Sub