- 帖子
- 406
- 主題
- 8
- 精華
- 0
- 積分
- 453
- 點名
- 0
- 作業系統
- WINDOWS 7
- 軟體版本
- 2007
- 閱讀權限
- 20
- 性別
- 男
- 來自
- 台灣
- 註冊時間
- 2015-2-7
- 最後登錄
- 2021-7-31
|
本帖最後由 n7822123 於 2020-4-5 22:01 編輯
回復 1# eric7765
準大的程式好像把沒有重複的部分，也一起列出來了
分享一下我的寫法
1.正常寫法~2個For迴圈
Sub L2()
Dim Arr, Brr, K, D As Object
Set D = CreateObject("Scripting.Dictionary")
[E1].CurrentRegion.ClearContents
Arr = Range([B1], [A65536].End(xlUp))
For R = 2 To UBound(Arr)
編$ = Arr(R, 1)
D(編) = D(編) & "," & Arr(R, 2)
Next
'===========
Brr = Array("重複值", "A", "B", "C", "D", "E", "F", "G")
[E1].Resize(1, UBound(Brr) + 1) = Brr
ReDim Brr(1 To D.Count, 1 To UBound(Brr))
For Each Key In D.keys
K = Split(D(Key), ",")
If UBound(K) > 1 Then
Ro% = Ro% + 1
Brr(Ro, 1) = Key
For C = 1 To UBound(K) 'ASC("A")=65
Brr(Ro, Asc(UCase(K(C))) - 63) = K(C)
Next
End If
Next
[E2].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub
2.比較難懂的寫法~1個For迴圈
(實測執行速度沒有比較快..........)
Sub L1()
Dim Arr, Brr, D As Object
Set D = CreateObject("Scripting.Dictionary")
[E1].CurrentRegion.ClearContents
Arr = Range([B1], [A65536].End(xlUp))
Brr = Array("重複值", "A", "B", "C", "D", "E", "F", "G")
[E1].Resize(1, UBound(Brr) + 1) = Brr
ReDim Brr(1 To UBound(Arr), 1 To UBound(Brr))
For R = 2 To UBound(Arr)
編$ = Arr(R, 1): 組$ = D(編)
If 組 = "" Then
D(編) = Arr(R, 2)
ElseIf Val(組) = 0 Then 'ASC("A")=65
Ro% = Ro% + 1: Brr(Ro, 1) = 編: D(編) = Ro
Brr(Ro, Asc(UCase(組)) - 63) = 組
Brr(Ro, Asc(UCase(Arr(R, 2))) - 63) = Arr(R, 2)
ElseIf Val(組) >= 1 Then
Brr(Val(組), Asc(UCase(Arr(R, 2))) - 63) = Arr(R, 2)
End If
Next
[E2].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
End Sub |
|
發表於 2020-4-5 21:52
| 