[發問] dictionary 用法

lalalada

以下為我的程式碼:

1. Dim Ar(), d As Object
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set dtemp = CreateObject("scripting.dictionary")
   
5. Ar = Range("A6:E" & [E6].End(xlDown).Row)
   
6. 
   
7. For i = 1 To UBound(Ar)
   
8.   If Not dtemp.exists(Left(Ar(i, 2), 4)) Then
   
9.   d.Add Ar(i, 2), Ar(i, 4)
   
10.   dic.Add Ar(i, 2), Ar(i, 5)
    
11.   dtemp.Add Left(Ar(i, 2), 4), Ar(i, 4)
    
12.   Else
    
13.   d(Ar(i, 2)) = d(Ar(i, 2)) + Ar(i, 4)
    
14.   dic(Ar(i, 2)) = dic(Ar(i, 2)) + Ar(i, 5)
    
15.   dtemp(Ar(i, 2)) = dtemp(Ar(i, 2)) + Ar(i, 4)
    
16.   End If
    
17. Next i

複製代碼

Ar 存放一個range
其形式長這樣
序        商品名稱              成交單價        購買數量
1        131A 電腦        150                 1,000
2        132A                 100                      0
3        55CR 冰箱        800                      0
4        55CR               1200                  250
5        55CR               1150                  100

因為名稱並未完全相同
想要用dictionary完成各項加總
可是不知道為何dtemp可以加總
但是 d跟dic就不行?
感謝m(_ _)m

GBKEE

回復 1# lalalada
想要用dictionary完成各項加總,可是不知道為何dtemp可以加總,但是 d跟dic就不行?
看看是這樣嗎?

1. Option Explicit
   
2. Sub EX()
   
3. Dim Ar(), d As Object, dtemp As Object, dic As Object, i As Integer, xlword(1 To 3) As String
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     Set dtemp = CreateObject("scripting.dictionary")
   
7.     Ar = Range("A6:E" & [E6].End(xlDown).Row)
   
8.     For i = 1 To UBound(Ar)
   
9.         xlword(1) = Ar(i, 2)          '全部字串
   
10.         xlword(2) = Left(Ar(i, 2), 4) '代號字串
    
11.         xlword(3) = Mid(Ar(i, 2), 5)  '品名字串
    
12.    
    
13.         d(xlword(1)) = d(xlword(1)) + Ar(i, 4)
    
14.         If xlword(1) <> xlword(2) Then dic(xlword(2)) = dic(xlword(2)) + Ar(i, 5)
    
15.         If xlword(3) <> "" Then dtemp(xlword(3)) = dtemp(xlword(3)) + Ar(i, 4)
    
16.     Next
    
17. End Sub

複製代碼

lalalada

回復  lalalada
想要用dictionary完成各項加總,可是不知道為何dtemp可以加總,但是 d跟dic就不行?
看看是 ...
GBKEE 發表於 2012-8-13 12:13

好像怪怪的...
最後一段
        d(xlword(1)) = d(xlword(1)) + Ar(i, 4)
        If xlword(1) <> xlword(2) Then dic(xlword(2)) = dic(xlword(2)) + Ar(i, 5)
        If xlword(3) <> "" Then dtemp(xlword(3)) = dtemp(xlword(3)) + Ar(i, 4)
意思分別是:
全名 = 代碼 + 品名
字典1建立關鍵字(記錄所有關鍵字，部分為全名，部分只有代碼)
若目前的全名不只有左邊代碼 則字典2(紀錄同時有代碼+品名項)加入關鍵字及索引
若品名不為空白則字典3(紀錄同時有代碼+品名項)加入關鍵字索引
這樣看起來最後無法把所有相同代碼的產品加總輸出?@@
ex. SSSL 電腦   $100    50
      SSSL             $150    25
      SSSL             $50      100
輸出成
SSSL   電腦   175
最後目標是
SSSL   電腦   $平均價格  175

lalalada

抱歉一開始敘述不清
我把原來的code加上註解

1. Dim Ar()
   
2. Set d = CreateObject("scripting.dictionary")
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set dtemp = CreateObject("scripting.dictionary")
   
5. Ar = Range("A6:E" & [E6].End(xlDown).Row)
   
6. 
   
7. For i = 1 To UBound(Ar)
   
8.   If dtemp.exists(Left(Ar(i, 2), 4)) = False Then  '若字典3代碼未紀錄
   
9.   d(Ar(i, 2)) = Ar(i, 4)                            '字典1紀錄全名及索引1
   
10.   dic(Ar(i, 2)) = Ar(i, 5)                         '字典2紀錄全名及索引2
    
11.   dtemp(Left(Ar(i, 2), 4)) = Ar(i, 4)              '字典3紀錄代碼及索引
    
12.     MsgBox "d:" & d(Ar(i, 2)) & d.keys & "  dic:" & dic(Ar(i, 2)) & " dtemp:" & dtemp(Left(Ar(i, 2), 4))
    
13.   Else                                                             '若字典3代碼已記錄
    
14.   dtemp(Left(Ar(i, 2), 4)) = dtemp(Left(Ar(i, 2), 4)) + Ar(i, 4) '字典3索引1加總
    
15.   d(Ar(i, 2)) = d(Ar(i, 2)) + Ar(i, 4)                          '字典1(全名)索引1加總
    
16.   dic(Ar(i, 2)) = dic(Ar(i, 2)) + Ar(i, 5)                    '字典2(全名)索引2加總
    
17.     MsgBox "ELSE    ""d:" & d(Ar(i, 2)) & "  dic:" & dic(Ar(i, 2)) & " dtemp:" & dtemp(Left(Ar(i, 2), 4))
    
18.   End If
    
19. Next i
    
20. 
    
21. [L6].Resize(d.Count, 1) = Application.Transpose(d.keys)          '輸出全名
    
22. [M6].Resize(d.Count, 1) = Application.Transpose(d.items)      '輸出索引1
    
23. [N6].Resize(dic.Count, 1) = Application.Transpose(dic.items) '輸出索引2

複製代碼

換句話說
希望最後能輸出字典1的全名和字典3的索引值...."
目前問題卡在當條件為否
dtemp可確實加總但d,dic不行(由msgbox可以觀察到)
感謝版大回復:)
本來以為已經沉到雲深不知處

GBKEE

回復 4# lalalada

上傳檔案 看看

lalalada

回復  lalalada
請傳上excel檔案
GBKEE 發表於 2012-8-13 16:09

阿 抱歉
完全忘記可以上傳...
我真笨..."
剛剛重寫了用Do...Loop的做法
也附在檔案裡
dictionary的方法 code裡的參照位置要稍微調整一下才能用

lalalada

回復 6# lalalada

檔案裡的code貼成沒註解版的了..."

GBKEE

回復 7# lalalada
咐檔 如有詳細說明 就不會霧裡看花了

ex. SSSL 電腦   $100    50
      SSSL             $150    25
      SSSL             $50      100
輸出成
SSSL   電腦   175
最後目標是
SSSL   電腦   $平均價格  175

程式碼依附檔欄位, 工作表1 的資料已排序過  定製

1. Sub arrange_trial()
   
2.     Dim Ar(), Axy(), d As Object, dic As Object, xlword As String
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     Ar = Sheets("工作表1").Range("A2:E" & Sheets("工作表1").[E2].End(xlDown).Row).Value
   
6.     '***  一般模組中: 沒指定工作表的 Range 是會作用中工作表ActiveSheet的Range   ****
   
7.     For i = 1 To UBound(Ar)
   
8.         If Len(Ar(i, 2)) > 4 Then xlword = Ar(i, 2)
   
9.         If Not d.Exists(xlword) Then
   
10.             d(xlword) = Array(Ar(i, 1), Ar(i, 2), , Ar(i, 4), Ar(i, 5))
    
11.             dic(xlword) = Array(Ar(i, 3))          'p
    
12.         Else
    
13.             Axy = d(xlword)   '取得 字典物件的items
    
14.             d(xlword) = Array(Axy(0), Axy(1), , Axy(3) + Ar(i, 4), Axy(4) + Ar(i, 5))
    
15.             
    
16.             Axy = dic(xlword) '取得 字典物件的items
    
17.             ReDim Preserve Axy(UBound(dic(xlword)) + 1)  '重置 Axy元素+1(Preserve: 員內容不變)
    
18.             Axy(UBound(Axy)) = Ar(i, 3)                  '加1 的元素
    
19.             dic(xlword) = Axy '置入 字典物件的items
    
20.         End If
    
21.     Next
    
22.     For Each k In d.keys
    
23.         Axy = d(k)
    
24.         Axy(2) = Application.Average(dic(k))  '平均數
    
25.         Axy(2) = Application.Round(Axy(2), 2) '四捨五入到小數點第2位
    
26.         d(k) = Axy
    
27.     Next
    
28.     Sheets("Output").[a5].Resize(d.Count, UBound(Ar, 2)) = Application.Transpose(Application.Transpose(d.items))
    
29. End Sub

複製代碼

lalalada

回復 8# GBKEE

我會了!:P
原來陣列這麼好用...
本來不熟以為反正可以用儲存格取代 我要再多研究..
而且dictionary竟然可以直接指定陣列
這次真的獲益良多
感謝版大!:)

Andy2483

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

資料表:

下載 (91.5 KB)

2023-4-14 14:19

結果表 執行前:

下載 (34.35 KB)

2023-4-14 14:20

執行結果:

下載 (52.7 KB)

2023-4-14 14:20

Option Explicit
Sub TEST()
Dim Brr, Y, R&, i&, j&, T$, T0$
Dim xR As Range, Sh1 As Worksheet, Sh2 As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("工作表1"): Set Sh2 = Sheets("Output")
Set xR = Sh1.[A1].CurrentRegion: Brr = xR
For i = 2 To UBound(Brr)
   T = Trim(Brr(i, 2))
   If T = "" Then GoTo i01
   If T Like "C### [A-Z]*" Then
      R = R + 1
      T0 = Split(T, " ")(0)
      Y(T0 & "|r") = R: Y(T0 & "|n") = 1: Y(T0 & "|tt") = Brr(i, 3)
      For j = 1 To 5: Brr(R, j) = Brr(i, j): Next
      GoTo i01
   End If
   Y(T & "|n") = Y(T & "|n") + 1
   Y(T & "|tt") = Y(T & "|tt") + Brr(i, 3)
   Brr(Y(T & "|r"), 3) = Round(Y(T & "|tt") / Y(T & "|n"), 2)
   Brr(Y(T & "|r"), 4) = Brr(Y(T & "|r"), 4) + Brr(i, 4)
   Brr(Y(T & "|r"), 5) = Brr(Y(T & "|r"), 5) + Brr(i, 5)
   
i01:
Next
[5:65536].Clear
Sh2.[A5].Resize(R, 5) = Brr
Set Y = Nothing: Set xR = Nothing: Erase Brr
Set Sh1 = Nothing: Set Sh2 = Nothing
End Sub