Sub TransposeData()
Dim sws As Worksheet, dws As Worksheet
Dim i As Long, lc As Long
Dim x, y, z
Dim dict
Application.ScreenUpdating = False
Set sws = Sheets("Sheet1")
On Error Resume Next
Set dws = Sheets("Output")
dws.Cells.Clear
On Error GoTo 0
If dws Is Nothing Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Output"
Set dws = ActiveSheet
End If
With dws.Range("A1:B1")
.Value = Array("Name", "Score 1")
.Font.Bold = True
.Font.Size = 12
End With
Set dict = CreateObject("Scripting.Dictionary")
x = sws.Range("A1").CurrentRegion.Value
For i = 2 To UBound(x, 1)
If Not dict.exists(x(i, 1)) Then
dict.Item(x(i, 1)) = x(i, 2)
Else
dict.Item(x(i, 1)) = dict.Item(x(i, 1)) & ";" & x(i, 2)
End If
Next i
dws.Range("A2").Resize(dict.Count).Value = Application.Transpose(dict.keys)
y = Application.Transpose(dict.items)
For i = 1 To UBound(y, 1)
z = Split(y(i, 1), ";")
dws.Range("B" & i + 1).Resize(1, UBound(z, 1) + 1).Value = Split(y(i, 1), ";")
Next i
lc = dws.UsedRange.Columns.Count
dws.Range("C1").Copy
dws.Range("B2", dws.Cells(UBound(y, 1) + 1, lc)).PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd
dws.Range("B1").AutoFill Destination:=dws.Range("B1", dws.Cells(1, lc)), Type:=xlFillDefault
dws.Range("A1").CurrentRegion.Borders.Color = vbBlack
dws.Columns.AutoFit
dws.Activate
dws.Range("A1").Select
Application.ScreenUpdating = True
End Sub