Sub x()
Dim oDic As Object, sNames() As String, vInput(), i As Long, n As Long
vInput = Sheet1.Range("A1", Sheet1.Range("C" & Rows.Count).End(xlUp)).Value
ReDim sNames(1 To UBound(vInput, 1), 1 To 3)
Set oDic = CreateObject("Scripting.Dictionary")
With oDic
For i = 1 To UBound(vInput, 1)
If Not .Exists(vInput(i, 1)) Then
n = n + 1
sNames(n, 1) = vInput(i, 1)
sNames(n, 2) = vInput(i, 2) & "(" & vInput(i, 3) & ")"
sNames(n, 3) = vInput(i, 3)
.Add vInput(i, 1), n
ElseIf .Exists(vInput(i, 1)) Then
sNames(.Item(vInput(i, 1)), 2) = sNames(.Item(vInput(i, 1)), 2) & ", " & vInput(i, 2) & "(" & vInput(i, 3) & ")"
sNames(.Item(vInput(i, 1)), 3) = sNames(.Item(vInput(i, 1)), 3) + vInput(i, 3)
End If
Next i
End With
Sheet2.Range("A1").Resize(n, 3) = sNames
End Sub
|