chrisovo的部落格

Sub 資料彙整()
Dim d, arr
Dim i As Long
Set d = CreateObject("scripting.dictionary")
arr = Range("a3:c17908")
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then 
d(arr(i, 1)) = arr(i, 2)

'如果Arr(i,1)不存在的話，那麼就將Arr(i,2)的值賦予給Arr(i,1)關鍵字
Else
d(arr(i, 1)) = d(arr(i, 1)) & "、" & arr(i, 2)

'如果Arr(i,1)已經存在的話，則將原先的賦值再加上Arr(i,2)後賦予給Arr(i,1)關鍵字
End If
Next

A = d.keys

B = d.items
Range("f4").Resize(d.Count) = Application.Transpose(A)
Range("g4").Resize(d.Count) = Application.Transpose(B)