Necesito macro para copiar y transponer celdas

Necesito una macro que haga lo siguiente; necesito copiar una cantidad de filas con celdas variables a partir de la columna B y trasponerlos enla columna A a partir de la celda A1, tengo la siguiente macro pero el problema es que me transpone una sola fila a la vez, y la que necesito es que recorra toda la columna B hasta completar todas y transponerlas en la col A, la macro que tengo es la siguiente:
Sub ordenar()
On Error Resume Next
ActiveSheet.Range("b1").End(xlDown).Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select 'Range("A1", Range("A1").End(xlToRight)).Select
 Selection.Copy
 Range("a500").End(xlUp).Select
 ActiveCell.Offset(1, 0).Activate
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Application.CutCopyMode = False
    ActiveSheet.Range("b1").End(xlDown).Select
Range(ActiveCell, ActiveCell.End(xlToRight)).Select 'Range("A1", Range("A1").End(xlToRight)).Select
 Selection.ClearContents
End Sub