If you want to do this with a macro, and your source data is always A2:B10, and you want to reorganize it starting in row 14 (with row 13 being headers), see if this comes close to what you want:
Sub Test1()
Application.ScreenUpdating = False
Range("13:65536").ClearContents
Dim w As Integer, x As Long, y As Range, z As Range
Set y = Range("A2:A10")
y.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("A13"), Unique:=True
For Each z In Range("A13:A" & Cells(Rows.Count, 1).End(xlUp).Row)
w = 2
With y
Dim u, v
Set u = .Find(z.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not u Is Nothing Then
v = u.Address
Do
Cells(z.Row, w).Value = Cells(u.Row, u.Column + 1).Value
w = w + 1
Set u = .FindNext(u)
Loop While Not u Is Nothing And u.Address <> v
End If
End With
Next z
Dim LC As Long, i As Integer
LC = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
i = 1
Range("A13").Value = Range("A1").Value
For Each z In Range(Cells(13, 2), Cells(13, LC))
z.Value = "Disc" & i
i = i + 1
Next z
Application.ScreenUpdating = True
End Sub
