麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] dictionary 用法 [打印本頁]

作者: lalalada 時間: 2012-8-8 17:44 標題: dictionary 用法

以下為我的程式碼:

Dim Ar(), d As Object
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Set dtemp = CreateObject("scripting.dictionary")
Ar = Range("A6:E" & [E6].End(xlDown).Row)
For i = 1 To UBound(Ar)
If Not dtemp.exists(Left(Ar(i, 2), 4)) Then
d.Add Ar(i, 2), Ar(i, 4)
dic.Add Ar(i, 2), Ar(i, 5)
dtemp.Add Left(Ar(i, 2), 4), Ar(i, 4)
Else
d(Ar(i, 2)) = d(Ar(i, 2)) + Ar(i, 4)
dic(Ar(i, 2)) = dic(Ar(i, 2)) + Ar(i, 5)
dtemp(Ar(i, 2)) = dtemp(Ar(i, 2)) + Ar(i, 4)
End If
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 時間: 2012-8-13 12:13

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

Option Explicit
Sub EX()
Dim Ar(), d As Object, dtemp As Object, dic As Object, i As Integer, xlword(1 To 3) As String
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
Set dtemp = CreateObject("scripting.dictionary")
Ar = Range("A6:E" & [E6].End(xlDown).Row)
For i = 1 To UBound(Ar)
xlword(1) = Ar(i, 2) '全部字串
xlword(2) = Left(Ar(i, 2), 4) '代號字串
xlword(3) = Mid(Ar(i, 2), 5) '品名字串
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)
Next
End Sub

複製代碼

作者: lalalada 時間: 2012-8-13 15:55

回復 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 時間: 2012-8-13 16:06

本帖最後由 lalalada 於 2012-8-13 16:09 編輯

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

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

複製代碼

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

作者: GBKEE 時間: 2012-8-13 16:12

回復 4# lalalada

上傳檔案看看

作者: lalalada 時間: 2012-8-13 16:35

本帖最後由 lalalada 於 2012-8-13 16:38 編輯

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

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

作者: lalalada 時間: 2012-8-13 16:40

回復 6# lalalada

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

作者: GBKEE 時間: 2012-8-13 21:31

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

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

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

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

複製代碼

作者: lalalada 時間: 2012-8-14 10:13

回復 8# GBKEE

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

作者: Andy2483 時間: 2023-4-14 14:20

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

資料表:
[attach]36135[/attach]

結果表執行前:
[attach]36136[/attach]

執行結果:
[attach]36137[/attach]

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)