Sub test()
Dim a, b, i As Long, ii As Long, t As Long, flg As Boolean
a = Cells(1).CurrentRegion.Value
ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) + 1)
b(1, 1) = a(1, 1)
With CreateObject("Scripting.Dictionary")
For i = 2 To UBound(a, 1)
If Not .exists(a(i, 1)) Then
.Item(a(i, 1)) = .Count + 2
b(.Count + 1, 1) = a(i, 1)
End If
For ii = 2 To UBound(b, 2)
If b(1, ii) = "" Then Exit For
If (b(1, ii) = a(i, 2)) * (b(.Item(a(i, 1)), ii) = "") Then
b(.Item(a(i, 1)), ii) = a(i, 3): flg = True: Exit For
End If
Next
If Not flg Then
t = ii: b(1, t) = a(i, 2)
b(.Item(a(i, 1)), t) = a(i, 3)
End If
flg = False
Next
i = .Count + 1
End With
With [e1].Resize(i, t)
.CurrentRegion.Clear
.Value = b
.Borders.Weight = 2
End With
End Sub
Bookmarks