|
Option Explicit
Sub atest()
Dim arr, brr, d, i, nr, nc
Set d = CreateObject("Scripting.Dictionary")
With Sheet2
nr = .Range("A65536").End(xlUp).Row
nc = 3
arr = .[A1].Resize(nr, nc)
End With
For i = 1 To UBound(arr)
If Not d.Exists(arr(i, 3)) Then
d.Add arr(i, 3), arr(i, 1)
Else
If InStr(d(arr(i, 3)), arr(i, 1)) = 0 Then
d(arr(i, 3)) = d(arr(i, 3)) & "," & arr(i, 1)
End If
End If
Next i
Sheet3.Range("A:E").ClearContents
arr = Application.WorksheetFunction.Transpose(d.keys)
brr = d.items
ReDim Preserve arr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(arr)
arr(i, 2) = brr(i - 1)
Next
Sheet3.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
Set d = Nothing
Set arr = Nothing
Set brr = Nothing
End Sub |
|