Sub es()
Dim t(), i As Long, c As Range, m As Object
Application.ScreenUpdating = 0: Application.DisplayAlerts = 0
Set m = CreateObject("Scripting.Dictionary")
t = Range("b9:f" & Cells(Rows.Count, 2).End(xlUp).Row).Value
For i = 1 To UBound(t)
m(t(i, 1)) = m(t(i, 1)) & t(i, 2) & "¤" & t(i, 3) & "¤" & t(i, 4) & "¤" & t(i, 5)
Next i
Range("b9" & ":f" & Cells(Rows.Count, 2).End(xlUp).Row).Delete
[b9].Resize(m.Count) = Application.Transpose(m.keys)
[c9].Resize(m.Count) = Application.Transpose(m.Items)
For Each c In Range("c9", Cells(Rows.Count, "c").End(xlUp))
c = Replace(c, "¤¤¤¤", "¤")
c.TextToColumns c, xlDelimited, , , , , , , True, "¤"
Next c
End Sub