Excel - Como copiar celdas con un incremento fijo

Sub Transpone()

'

    Sheets("Hoja1").Select

    Comprobar = True: Contador = 0

    a = 1

    b = 3

    Do    ' Bucle externo.

    Do While Contador < 65000

        Contador = Contador + 1

        If Range("A" & a) <> "" Then

    Range("A" & a & ":A" & b).Select

    Selection.Copy

    Sheets("Hoja2").Select

    k = Range("A" & Cells.Rows.Count).End(xlUp).Row + 1

    Range("A" & k).Select

    Selection.PasteSpecial Transpose:=True

    Sheets("Hoja1").Select

    a = a + 3

    b = b + 3

        Else

    Comprobar = False

       Exit Do

        End If

     Loop

Loop Until Comprobar = False

End Sub