[attach]32602[/attach]

Sub test1()
[料件!C2:C6000].ClearContents '清除C資料
Set xD = CreateObject("Scripting.Dictionary") '字典
Sheets("料件").Select '跳到
arr = Range([位置!A2], [位置!D65536].End(xlUp))
For i = 1 To UBound(arr)
xD(arr(i, 1)) = xD(arr(i, 1)) & "," & arr(i, 4)
Next i
Set xR = Range([A2], [A65536].End(xlUp))
For Each xT In xR
Cells(xT.Row, "C") = xD(xT.Value)
Next
Set xD = Nothing
End Sub

1. Sub test1()
2. Application.ScreenUpdating = False
3.     [料件!C2:C6000].ClearContents '清除C資料
4.     Set xD = CreateObject("Scripting.Dictionary") '字典
5.     Sheets("料件").Select '跳到
6.     arr = Range([位置!A2], [位置!D65536].End(xlUp))
7.     Range(Sheets(2).Cells(2, 1).End(xlDown), Sheets(2).Cells(2, 4)).Sort Sheets(2).Cells(2, 4).End(xlDown)
8.
9.     For I = 1 To UBound(arr)
10.         If I = UBound(arr) Then Exit For
11.         If arr(I, 4) <> arr(I + 1, 4) Then
12.             xD(arr(I, 1)) = xD(arr(I, 1)) & "," & arr(I, 4)
13.         End If
14.     Next I
15.
16.     Set xR = Range([A2], [A65536].End(xlUp))
17.     For Each xT In xR
18.         Cells(xT.Row, "C") = xD(xT.Value)
19.     Next
20.
21.     Set xD = Nothing
22. Application.ScreenUpdating = True
23. End Sub

Sub TEST_A1()
Dim Arr, xD, i&, T1\$, T2\$, T3\$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([位置!A1], [位置!D65536].End(xlUp))
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 4)
If T1 = "" Or T2 = "" Then GoTo 101
T3 = T1 & "|" & T2:  xD(T3) = xD(T3) + 1 '用兩個關鍵字組合, 排除重覆
If xD(T3) = 1 Then xD(T1) = xD(T1) & "," & T2  'xD(T3) = 1 為首次出現的, 加入字串中, 超過1, 略過
101: Next i
Arr = Range([料件!A1], [料件!A65536].End(xlUp))
For i = 2 To UBound(Arr)
Arr(i - 1, 1) = Mid(xD(Arr(i, 1) & ""), 2) '字串首字符為"逗號", 須用mid取第2個字以後的字元
Next i
[料件!C2].Resize(UBound(Arr) - 1) = Arr
End Sub

Sub TEST_A2()
Dim Arr, xD, i&, T1\$, T2\$, T3\$, xR As Range
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([位置!A1], [位置!D65536].End(xlUp))
For i = 2 To UBound(Arr)
T1 = Arr(i, 1): T2 = Arr(i, 4)
If T1 = "" Or T2 = "" Then GoTo 101
T3 = T1 & "|" & T2:  xD(T3) = xD(T3) + 1
If xD(T3) = 1 Then xD(T1) = xD(T1) & IIf(xD(T1) = "", "", ",") & T2  '用 iif 避免字串開頭出現"逗號"
101: Next i
For Each xR In Range([料件!A2], [料件!A65536].End(xlUp)) '直接在儲存格逐一填入, 速度慢
xR(1, 3) = xD(xR & "")  '注意:xD(xR & "") 中的"雙引號"不可省略, 或用xD(xR.Value)
Next
End Sub

"數值"及"文字"格式, 會視為不同,

dim T\$ 或  dim T as string
T = 123
xd(T) 即等同 xd("123")

https://blog.xuite.net/hcm195222/blog/589401247

hcm19522提供的函數蠻有意思，我一開始也是用函數寫，結果資料跑了30分鐘，太久了才開始用VBA練習

 歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)