Hi, Try this.
I assumed your Names are in Column "A" and the Dates in Column "B".
The resulting data is in sheet (2) Starts "A1", but you can place in where ever you like by altering the Ranges and sheet at the end of the code.
Sub Trans()
Dim a, K(), Q(), i As Long, n As Long, lCol As Long
Dim Rng As Range
Set Rng = Range(Range("A1"), Range("B" & Rows.Count).End(xlUp))
a = Rng.Value
ReDim K(1 To UBound(a, 1), 1 To Columns.Count)
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For i = 1 To UBound(a, 1)
If Not .Exists(a(i, 1)) Then
n = n + 1
K(n, 1) = a(i, 1): K(n, 2) = Format(a(i, 2), "dd/mm/yy")
.Add a(i, 1), Array(n, 2)
Else
Q = .Item(a(i, 1))
Q(1) = Q(1) + 1
K(Q(0), Q(1)) = Format(a(i, 2), "dd/mm/yy")
lCol = Application.Max(lCol, Q(1))
.Item(a(i, 1)) = Q
End If
Next
With Sheets("Sheet2")
.Range("A1").Resize(n, lCol).Value = K
.Columns.AutoFit
End With
End With
End Sub
Regards Mick
Bookmarks