OK I have a macro which takes into account all the possibilites as far as I think . There are three macros. But it is enough if you run the macro "test" which incorrporates the other two.

sub test()
Dim yr, rng As Range, c As Range, cfind As Range
Dim rng1 As Range, add As String, j As Integer
Worksheets("sheet2").Cells.Clear
unique
On Error Resume Next
With Worksheets("sheet2")
Set rng = Range(.Range("A1"), .Range("A1").End(xlToRight))
For Each c In rng
yr = c.Value
j = c.Column
'msgbox yr
'msgbox j
    With Worksheets("sheet1")
    Set cfind = .Cells.Find(what:=yr, lookat:=xlWhole)
    'msgbox cfind.Address
    Set rng1 = Range(cfind.Offset(0, 2), .Cells(cfind.Row, Columns.Count).End(xlToLeft)) 'cfind.End(xlToRight))
    'msgbox rng1.Address
    rng1.Copy
    add = cfind.Address
    'msgbox cfind.Address
    'msgbox j
     
    Worksheets("sheet2").Cells(Rows.Count, j).End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True
    
   
    Do
    Set cfind = .Cells.FindNext(cfind)
    If cfind.Address = add Then GoTo line1
     'msgbox cfind.Address
    
    Set rng1 = Range(cfind.Offset(0, 2), .Cells(cfind.Row, Columns.Count).End(xlToLeft)) 'cfind.End(xlToRight)))
    'msgbox rng1.Address
    rng1.Copy
    'msgbox j
    'msgbox rng1.Address
     Worksheets("sheet2").Cells(Rows.Count, j).End(xlUp).Offset(1, 0).PasteSpecial , Transpose:=True
        Loop
line1:

End With
Next c
End With

remove_blanks

Application.CutCopyMode = False
End Sub

Sub unique()
With Worksheets("sheet2")
Sheets("Sheet1").Range("A1:A7").AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=.Range("A1"), unique:=True
 Range(.Range("a1"), .Range("a1").End(xlDown)).Copy
 .Range("B1").PasteSpecial , Transpose:=True
 .Range("a1:B1").EntireColumn.Delete
        
        
End With

End Sub

Sub remove_blanks()
Dim rng As Range
'Range("A1:C12").Select
With Worksheets("sheet2").UsedRange
Set rng = .SpecialCells(xlCellTypeBlanks)
    
    rng.Delete Shift:=xlUp
    End With

End Sub