try
Option Explicit
Sub test()
Dim ws As Worksheet, a, i As Long, maxCol As Long, w
For Each ws In Worksheets
With ws.Range("a1").CurrentRegion
a = .Resize(, 2).Value
ReDim Preserve a(1 To UBound(a, 1), 1 To 100)
With CreateObject("Scripting.Dictionary")
.CompareMode = 1
For i = 3 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Item(a(i, 1)) = VBA.Array(i, 2)
Else
w = .Item(a(i, 1))
w(1) = w(1) + 1
If w(1) > UBound(a, 2) Then
ReDim Preserve _
a(1 To UBound(a, 1), 1 To UBound(a, 2) + 100)
End If
a(w(0), w(1)) = a(i, 2)
a(i, 2) = Empty
.Item(a(i, 1)) = w
maxCol = Application.Max(maxCol, w(1))
End If
Next
End With
.Resize(, maxCol).Value = a
End With
Next
End Sub
Bookmarks