Scripting.Dictionary的應用

帖子: 1425
主題: 40
精華: 0
積分: 1449
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-4-16

12^#

發表於 2023-6-20 10:19 | 只看該作者

謝謝論壇,謝謝各位前輩
後學藉此帖練習陣列與字典,學習方案如下,請各位前輩指教

資料表:

結果表執行前:

執行結果:

Option Explicit
Sub TEST_1()
Dim Brr, Crr, Z, i&, j%, R&, Y&, T$
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([工作表1!D1], [工作表1!A65536].End(3))
ReDim Crr(1 To UBound(Brr), 1 To 3)
For i = 1 To UBound(Brr)
T = Brr(i, 2) & "|" & Brr(i, 4)
R = Z(T)
If R = 0 Then
   Y = Y + 1: R = Y
   For j = 1 To 3: Crr(R, j) = Brr(i, j + 1): Next
   Z(T) = R: GoTo i01
End If
Crr(R, 2) = Crr(R, 2) + Brr(i, 3)
i01: Next
With [Summary!A1].Resize(Y, 3)
.EntireColumn.ClearContents
.Value = Crr
End With
Set Z = Nothing: Erase Brr, Crr
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

　暱稱: jjjohn

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

11^#

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

回復 10# samwang

謝謝您解釋.

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

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

　暱稱: jjjohn

帖子: 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
最後登錄: 2023-9-21

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

　暱稱: jjjohn

帖子: 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
最後登錄: 2023-9-21

6^#

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

回復 5# john2006168

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

　暱稱: jjjohn

帖子: 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
最後登錄: 2023-9-21

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