Scripting.Dictionary的應用

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

2^#

發表於 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

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

3^#

發表於 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

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

4^#

發表於 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

john2006168

　暱稱: jjjohn

中學生 Rank: 2

帖子: 178
主題: 65
精華: 0
積分: 252
點名: 0
作業系統: WINDOW7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2010-5-4
最後登錄: 2024-2-1

5^#

發表於 2021-5-17 10:17 | 只看該作者

回復 3# samwang

謝謝提供兩種方法,慢慢學習中.
請問可否幫忙解釋這句意思?
xD(T & "") = xD(T & "") + T2

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

6^#

發表於 2021-5-17 10:55 | 只看該作者

回復 5# john2006168

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

john2006168

　暱稱: jjjohn

中學生 Rank: 2

帖子: 178
主題: 65
精華: 0
積分: 252
點名: 0
作業系統: WINDOW7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2010-5-4
最後登錄: 2024-2-1

7^#

發表於 2021-5-18 15:23 | 只看該作者

回復 6# samwang

samwang,請問一下如果我加多一欄和多一個條件,相同的"LOCATION"加在一起,請問這樣怎麼寫.

擷取.PNG (7.86 KB)

TEST2.zip (12.73 KB)

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

8^#

發表於 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

john2006168

　暱稱: jjjohn

中學生 Rank: 2

帖子: 178
主題: 65
精華: 0
積分: 252
點名: 0
作業系統: WINDOW7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2010-5-4
最後登錄: 2024-2-1

9^#

發表於 2021-5-20 12:22 | 只看該作者

回復 8# samwang
可以運行,但是有些地方不是很理解,可否幫忙註釋一下.

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

10^#

發表於 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