Scripting.Dictionary的應用

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

1^# 跳轉到 »

發表於 2021-5-16 20:57 | 顯示全部帖子

回復 1# john2006168

請試看看，謝謝。
Sub test()
Dim Arr, xD, Ar(), T, T2%, i&, M%, N%
Set xD = CreateObject("Scripting.Dictionary")
Sheets("工作表1").Range("B1:C1").Copy Sheets("Summary").Range("A1")
Arr = Sheets("工作表1").[a1].CurrentRegion
ReDim Ar(1 To UBound(Arr), 1 To 2)
For i = 2 To UBound(Arr)
T = Arr(i, 2): T2 = Arr(i, 3)
If xD.Exists(T & "") Then
      M = xD(T & "")
      Ar(M, 2) = Ar(M, 2) + T2
Else
      N = N + 1: xD(T & "") = N
      Ar(N, 1) = T: Ar(N, 2) = T2
End If
Next
Sheets("Summary").[A2].Resize(N, 2) = Ar
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

2^#

發表於 2021-5-17 07:52 | 顯示全部帖子

回復 1# john2006168

不一樣寫法，請再測試看看，謝謝。
Sub test2()
Dim Arr, xD, T, T2%, i&
Set xD = CreateObject("Scripting.Dictionary")
Sheets("工作表1").Range("B1:C1").Copy Sheets("Summary").Range("A1")
Arr = Sheets("工作表1").[a1].CurrentRegion
For i = 2 To UBound(Arr)
T = Arr(i, 2): T2 = Arr(i, 3)
xD(T & "") = xD(T & "") + T2
Next
Sheets("Summary").[A2].Resize(xD.Count) = Application.Transpose(xD.keys)
Sheets("Summary").[B2].Resize(xD.Count) = Application.Transpose(xD.items)
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

3^#

發表於 2021-5-17 08:38 | 顯示全部帖子

更新#3樓，放了將表頭第一列也可以寫入字典即可，謝謝。
Sub test3()
Dim Arr, xD, T, T2, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheets("工作表1").[A1].CurrentRegion
For i = 1 To UBound(Arr)
T = Arr(i, 2): T2 = Arr(i, 3)
xD(T & "") = xD(T & "")
xD(T & "") = xD(T & "") + T3
Next
Sheets("Summary").[A1].Resize(xD.Count) = Application.Transpose(xD.keys)
Sheets("Summary").[B1].Resize(xD.Count) = Application.Transpose(xD.items)
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

4^#

發表於 2021-5-17 10:55 | 顯示全部帖子

回復 5# john2006168

不好意思4樓，T3須改為T2
xD(T & "") = xD(T & "") + T2 ' Name有重複時，Oder 數值累加

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

5^#

發表於 2021-5-18 20:41 | 顯示全部帖子

回復 7# john2006168

請測試看看，條件複雜時，可以使用字典+數組陣列比較容易解，謝謝。

Sub test()
Dim Arr, xD, T, T2, T3, T4, i&, M%, N%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheets("工作表1").[A1].CurrentRegion
For i = 1 To UBound(Arr)
T = Arr(i, 2) & "|" & Arr(i, 4)
T2 = Arr(i, 2): T3 = Arr(i, 3): T4 = Arr(i, 4)
If xD.Exists(T & "") Then
      M = xD(T & ""): Arr(M, 2) = Arr(M, 2) + T3
Else
      N = N + 1: xD(T & "") = N
      Arr(N, 1) = T2: Arr(N, 2) = T3: Arr(N, 3) = T4
End If
Next
Sheets("Summary").[A1].Resize(N, 3) = Arr
End Sub

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2023-9-21

6^#

發表於 2021-5-20 14:42 | 顯示全部帖子

回復 9# john2006168

解釋寫得不好時，請見諒，感謝。

Sub test()
Dim Arr, xD, T, T2, T3, T4, i&, M%, N%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Sheets("工作表1").[A1].CurrentRegion '資料裝入數組
For i = 1 To UBound(Arr)
   T = Arr(i, 2) & "|" & Arr(i, 4) '關鍵條件串連一起當作key
   T2 = Arr(i, 2): T3 = Arr(i, 3): T4 = Arr(i, 4)
   If xD.Exists(T & "") Then       'key有無在字典
      M = xD(T & "")                   '找到同key的位置
      Arr(M, 2) = Arr(M, 2) + T3  '累加
   Else
      N = N + 1: xD(T & "") = N  'key裝入字典且編流水號
      Arr(N, 1) = T2: Arr(N, 2) = T3: Arr(N, 3) = T4 '將符合條件的資料裝到結果的數組
   End If
Next
Sheets("Summary").[A1].Resize(N, 3) = Arr  '結果顯示
End Sub

TOP

[收藏此主題] [關注此主題的新回復]

[通過 QQ、MSN 分享給朋友]