move data from diff rows in 1 column into new columns based on dup data in another field

the file "lxndeb 140730.xlsm" is attached
download the file, open, enable macros

the data is in sheet1 and result will be in sheet2.
the macro is module 1 of vbeditor of the file and also repeated below

Sub test()
Dim nname As Range, unq As Range, cunq As Range, rdata As Range
Dim dest As Range, rname As String
Application.ScreenUpdating = False
Worksheets("sheet2").Cells.Clear
With Worksheets("sheet1")
Set rdata = .Range("A1").CurrentRegion
Set unq = .Range("A1").End(xlDown).Offset(5, 0)
Set nname = Range(.Range("A1"), .Range("A1").End(xlDown))
nname.AdvancedFilter xlFilterCopy, , unq, True
Set unq = Range(unq.Offset(1, 0), unq.End(xlDown))
For Each cunq In unq
rname = cunq
rdata.AutoFilter field:=1, Criteria1:=cunq
rdata.Offset(1, 0).Resize(rdata.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Columns(2).Copy
With Worksheets("sheet2")
Set dest = .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
dest = rname
dest.Offset(0, 1).PasteSpecial Transpose:=True
End With
.AutoFilterMode = False
Next cunq
Range(unq.Offset(-1, 0), unq.End(xlDown)).Cells.Clear
End With
MsgBox "macro done SEE SHEET2"
Application.ScreenUpdating = True
End Sub