Sub TestSub()
Dim i, j, k, arr, brr, x, y, rng As Range
Dim dic As Object, key As String, dickeys, Item, dicItems
Set dic = CreateObject("scripting.dictionary")
With Sheet1
arr = .Range("a1:g" & Cells(Rows.Count, "A").End(xlUp).Row)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = LBound(arr) + 1 To UBound(arr)
key = arr(i, 2)
If Not dic.Exists(key) Then
k = k + 1
For j = 1 To UBound(brr, 2)
brr(k, j) = arr(i, j)
Next
dic(key) = dic.Count + 1
Else
行号 = dic(key)
brr(行号, 4) = brr(行号, 4) & "," & arr(i, 4)
End If
Next
.[a2].Resize(1000, 10) = ""
.[a2].Resize(k, UBound(brr)) = brr
End With
End Sub
|