HOW CAN I COPY COLUMN TO ROWS

Sub test()
Dim rng As Range, rng1 As Range, x, c1 As Range, m As Integer
Dim foundrange As Range, resultrange As Range
m = 0
Worksheets("sheet2").Cells.Clear
With Worksheets("sheet1")
Set rng = Range(.Range("A1"), .Range("A1").End(xlDown))
rng.AdvancedFilter action:=xlFilterCopy, copytorange:=Worksheets("sheet2").Range("a1"), unique:=True
Do
x = Worksheets("sheet2").Range("a2").Offset(m, 0)
If x = "" Then Exit Do
 Set foundrange = findall(rng, x)
 If foundrange Is Nothing Then Exit Do
foundrange.Offset(0, 1).Copy
Worksheets("sheet2").Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True

m = m + 1
Loop
End With


End Sub
Function findall(source As Range, findwhat) As Range
Dim foundcell As Range
Dim firstfound As Range
Dim lastcell As Range
Dim resultrange As Range
With source
Set lastcell = .Cells(.Cells.Count)
End With
On Error Resume Next
On Error GoTo 0
Set foundcell = source.Cells.Find(what:=findwhat, LookAt:=xlWhole)
If Not foundcell Is Nothing Then
Set firstfound = foundcell
Set resultrange = foundcell
End If
Do
Set foundcell = source.Cells.FindNext(after:=foundcell)
If foundcell Is Nothing Then Exit Do
If foundcell.Address = firstfound.Address Then Exit Do
Set resultrange = Application.Union(resultrange, foundcell)
Loop
Set findall = resultrange
End Function