Bom dia!!

Eu já postei algo parecido use a pesquisa.

Tente adaptar o código abaixo!

Sub AleVBA_11813()
Dim Rng As Range
Dim RngA As Range
Dim Ac As Range
Dim c As Long
Application.ScreenUpdating = False
With Sheets("Plan1")
    Set RngA = .Range(.Range("A1"), .Cells(1, Columns.Count).End(xlToLeft))
End With

For Each Ac In RngA
    Set Rng = Range(Cells(1, Ac.Column), Cells(Rows.Count, Ac.Column).End(xlUp))
    Rng.Copy
    Sheets("Sheet2").Range("A1").Offset(, c).PasteSpecial , Transpose:=True
    c = c + Rng.Count
Next Ac
Application.ScreenUpdating = True
End Sub

Att

Boa noite alexandrevba

Muito obrigado pela ajuda.
Deveria ter pesquisado melhor no fórum.
Abraços.

fabiosp