Try
Sub test()
Dim a, b, i As Long, ii As Long, w
With Cells(1).CurrentRegion
a = .Value
ReDim b(1 To UBound(a, 1), 1 To 2)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 2)) Then
.Item(a(i, 2)) = VBA.Array(.Count + 1, 2)
b(.Count, 1) = a(i, 2): b(.Count, 2) = a(i, 1)
Else
w = .Item(a(i, 2)): w(1) = w(1) + 1:
.Item(a(i, 2)) = w
If UBound(b, 2) < w(1) Then ReDim Preserve b(1 To UBound(b, 1), 1 To w(1))
b(w(0), w(1)) = a(i, 1)
End If
Next
i = .Count
End With
With .Offset(, .Columns.Count + 3).Resize(, UBound(b, 2))
.CurrentRegion.Clear
With .Cells(1).Resize(, 2)
.Value = Application.Index(a, 0, [{2,1}])
.Font.Bold = True
End With
.Rows(2).Resize(i).Value = b
If UBound(b, 2) > 2 Then
.Cells(1, 2).AutoFill .Cells(1, 2).Resize(, UBound(b, 2) - 1)
End If
With .CurrentRegion
.Borders.Weight = 2
.HorizontalAlignment = xlCenter
.Columns.AutoFit
End With
End With
End With
End Sub
Bookmarks