常见字典用法集锦及代码详解
目錄
- 前言
- 字典的簡介
- 1. 字典對象
- 1.1 Add 方法
- 1.2 Exists 方法
- 1.3 Keys 方法
- 1.4 Items 方法
- 1.5 Remove 方法
- 1.6 RemoveAll 方法
- 2. 實例
- 2.1 實例1. 普通常見的求不重復值問題
- 2.1.1 問題
- 2.1.2 實例代碼
- 2.1.3 代碼詳解
- 2.2 實例2 求多表的不重復值問題
- 2.2.1 問題
- 2.2.2 代碼
- 2.2.3 代碼詳解
- 2.3 實例3 A列中顯示1 ~ 1000中被6除余1和余5 的數字
- 2.3.1 問題
- 2.3.2 代碼
- 2.3.3 代碼詳解
- 2.4 實例4 拆分數據不重復
- 2.4.1 問題
- 2.4.2 代碼
- 2.4.3 代碼詳解
- 2.4.4 山菊花版主的代碼
- 2.4.5 代碼詳解
- 2.5 實例5 前期綁定的字典實例
- 2.5.1 問題
- 2.5.2 代碼
- 2.5.3 代碼詳解
- 2.6 實例6 多條件復雜匯總
- 2.6.1 問題
- 2.6.2 代碼
- 2.6.3 代碼詳解
- 2.7 實例7 字典法排序
- 2.7.1 問題
- 2.7.2 代碼
- 2.7.3 代碼詳解
- 2.8 實例8 2級動態數據有效性問題
- 2.8.1 問題
- 2.8.2 代碼
- 2.8.3 代碼詳解
- 2.9 實例9 字典取行數，數組重新賦值
- 2.9.1 問題
- 2.9.2 代碼
- 2.9.3 代碼詳解
- 2.10 實例10 先字典求得行后顯示整行數據
- 2.10.1 問題
- 2.10.2 代碼
- 2.10.3 代碼詳解
- 2.11 實例11 關鍵字賦給兩列后用Replace方法
- 2.11.1 問題
- 2.11.2 代碼
- 2.11.3 代碼詳解
- 2.12 實例12 復雜報表匯總
- 2.12.1 問題的提出 ：
- 2.12.2 代碼
- 2.12.3 代碼詳解
- 3. 后語
前言
????????凡是上過學校的人都使用過字典，從新華字典、成語詞典，到英漢字典以及各種各樣數不勝數的專業字典，字典是上學必備的、經常查閱的工具書。有了它們，我們可以很方便的通過查找某個關鍵字，進而查到這個關鍵字的種種解釋，非?？旖輰嵱?。
????????凡是上過 EH 論壇的想學習VBA里面字典用法的，幾乎都看過研究過 northwolves 狼版主、oobird版主的有關字典的精華貼和經典代碼。我也是從這里接觸到和學習到字典的，在此，對他們表示深深的謝意，同時也對很多把字典用得出神入化的高手們致敬，從他們那里我們也學到了很多，也得到了提高。
????????字典對象只有 4個屬性 和 6個方法 ，相對其它的對象要簡潔得多，而且容易理解使用方便，功能強大，運行速度非常快，效率極高。深受大家的喜愛。
????????本文希望通過對一些字典應用的典型實例的代碼的詳細解釋來給初次接觸字典和想要進一步了解字典用法的朋友提供一點備查的參考資料，希望大家能喜歡。
????????給代碼注釋估計是大家都怕做的，因為往往是出力不討好的，稍不留神或者自己確實理解得不對，還會貽誤他人。所以下面的這些注釋如果有不對或者不妥當的地方，請大家跟帖時指正批評，及時改正。
字典的簡介
????????字典（Dictionary）對象是微軟Windows腳本語言中的一個很有用的對象。
????????附帶提一下，有名的 正則表達式（RegExp）對象和能方便處理驅動器、文件夾和文件的（FileSystemObject ）對象也是微軟Windows腳本語言中的一份子。
????????字典對象相當于一種聯合數組，它是由具有唯一性的關鍵字（Key）和它的項（Item）聯合組成。就好像一本字典書一樣，是由很多生字和對它們對應的注解所組成。比如字典的 “典” 字的解釋是這樣的：
???????? “典” 字就是具有唯一性的關鍵字，后面的解釋就是它的項，和“典”字聯合組成一對數據。
常用關鍵字英漢對照：
| Dictionary | 字典 |
| Key | 關鍵字 |
| Item | 項，或者譯為 條目 |
1. 字典對象
????????字典對象的方法有6個：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。
1.1 Add 方法
向 Dictionary 對象中添加一個關鍵字項目對。
-
語法：
object.Add (key, item) -
參數：
數說明 object 必選項。總是一個 Dictionary 對象的名稱。 key 必選項。與被添加的 item 相關聯的 key。 item 必選項。與被添加的 key 相關聯的 item 說明：如果 key 已經存在，那么將導致一個錯誤。
-
常用語句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" -
代碼詳解：
1）Dim d： 創建變量，也稱為聲明變量。變量d聲明為可變型數據類型(Variant)，d后面沒有寫數據類型，默認就是可變型數據類型(Variant)。也有寫成Dim d As Object的，聲明為 對象 。
2）Set d = CreateObject("Scripting.Dictionary")：創建字典對象，并把字典對象賦給變量d。這是最常用的一句代碼。所謂的 “后期綁定” 。用了這句代碼就不用先引用 C:\windows\system32\scrrun.dll了。
3）d.Add "a", "Athens"：添加一關鍵字"a"和對應于它的項”Athens”。
4）d.Add "b", "Belgrade"：添加一關鍵字"b"和對應于它的項"Belgrade"。
5） d.Add "c", "Cairo"：添加一關鍵字"c"和對應于它的項"Cairo"。
1.2 Exists 方法
如果 Dictionary 對象中存在所指定的關鍵字則返回 true，否則返回 false。
-
語法：
object.Exists(key) -
參數:
參數說明 object 必選項?？偸且粋€ Dictionary 對象的名稱。 key 必選項。需要在 Dictionary 對象中搜索的 key 值。 -
常用語句：
Dim d, msg$ Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" If d.Exists("c") Thenmsg = "指定的關鍵字已經存在。" Elsemsg = "指定的關鍵字不存在。" End If
-
代碼詳解：
1）Dim d, msg$ ：聲明變量，d見前例；msg$ 聲明為字符串數據類型(String)，一般寫法為Dim msg As String。String 的類型聲明字符為美元號 ($)。
2）If d.Exists("c") Then：如果字典中存在關鍵字"c"，那么執行下面的語句。
3）msg = "指定的關鍵字已經存在。"：把 "指定的關鍵字已經存在。" 字符串 賦給變量 msg。
4）Else ：否則執行下面的語句。
5）msg = "指定的關鍵字不存在。" ：把 "指定的關鍵字不存在。" 字符串 賦給變量msg。
6）End If ：結束If …Else…Endif判斷。
1.3 Keys 方法
返回一個數組，其中包含了一個 Dictionary 對象中的全部現有的關鍵字。
-
語法：
object.Keys()其中 object 總是一個 Dictionary 對象的名稱。
-
常用語句：
Dim d, k Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" k=d.Keys [B1].Resize(d.Count,1)=Application.Transpose(k)
-
代碼詳解：
1）Dim d, k ：聲明變量，d見前例；k默認是 可變型數據類型 (Variant)。
2）k=d.Keys：把字典中存在的所有的關鍵字賦給變量k。得到的是一個一維數組，下限為0，上限為d.Count-1。這是數組的默認形式。
3）[B1].Resize(d.Count,1)=Application.Transpose(k) ：這句代碼是很常用很經典的代碼，所以這里要多說一些：
Resize是 Range對象 的一個屬性，用于調整指定區域的大小，它有兩個參數：
①、第一個是行數，本例是d.Count，指的是字典中關鍵字的數量，整本字典中有多少個關鍵字，本例d.Count=3，因為有 3 個關鍵字。呵呵，是不是說多了。
②、第二個是列數，本例是1。這樣：
＝左邊的意思就是：把一個單元格B1調整為以B1開始的一列單元格區域，行數等于字典中關鍵字的數量d.Count，就是把單元格B1調整為單元格區域B1：B3了。
＝右邊的k是個一維數組，是水平排列的。
????????我們知道 Excel 工作表函數里面有個轉置函數 Transpose，用它可以 把水平排列的置換成豎向排列。但是在 VBA 中不能直接使用該工作表函數，需要通過Application對象的WorksheetFunction屬性來使用它。所以完整的寫法是Application. WorksheetFunction.Transpose(k)，中間的WorksheetFunction可省略。
~現在可以解釋這句代碼了：
把字典中所有的關鍵字賦給以B1單元格開始的單元格區域中。
1.4 Items 方法
返回一個 數組，其中包含了一個 Dictionary 對象中的所有項目。
-
語法：
object.Items( )其中 object 總是一個 Dictionary 對象的名稱。
-
常用語句：
Dim d, t Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" t=d.Items [C1].Resize(d.Count,1)=Application.Transpose(t) -
代碼詳解：
1）Dim d, t ：聲明變量，d見前例；t默認是可變型數據類型(Variant)。
2）t=d.Items ：把字典中所有的關鍵字對應的項賦給變量t。得到的也是一個一維數組，下限為0，上限為d.Count-1。這是數組的默認形式。
3）[C1].Resize(d.Count,1)=Application.Transpose(t) ：有了上面Keys方法的解釋這句代碼就不用多說了，就是把字典中所有的關鍵字對應的項賦給以C1單元格開始的單元格區域中。
1.5 Remove 方法
Remove 方法從一個 Dictionary 對象中 清除 一個關鍵字，項目對。
-
語法：
object.Remove(key )其中 object 總是一個 Dictionary 對象的名稱。
key：必選項。key 與要從 Dictionary 對象中刪除的關鍵字、項目對相關聯。
說明：如果所 指定的關鍵字，項目對不存在，那么將導致一個 錯誤 。
-
常用語句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" ' …… d.Remove(“b”) -
代碼詳解：
1）d.Remove("b")：清除字典中 "b" 關鍵字和與它對應的項。清除之后，現在字典里只有2個關鍵字了。
1.6 RemoveAll 方法
RemoveAll 方法從一個 Dictionary 對象中清除所有的 關鍵字，項目對。
-
語法：
object.RemoveAll()其中 object 總是一個 Dictionary 對象的名稱。
-
常用語句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" ' …… d.RemoveAll -
代碼詳解：
1）d.RemoveAll：清除字典中所有的數據。也就是清空這字典，然后可以添加新的關鍵字和項，形成一本新字典。
字典對象的屬性有4個：Count屬性、Key屬性、Item屬性、CompareMode屬性。
-
① Count 屬性：
屬性說明 Count 返回一個Dictionary 對象中的項目數。只讀屬性。 object.Count：其中 object一個字典對象的名稱。
常用語句：
Dim d,n% Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" n = d.Count代碼詳解：
1）Dim d, n% ：聲明變量，d見前例；n被聲明為整型數據類型(Integer)。一般寫法為Dim n As Integer 。 Integer 的類型聲明字符為百分比號 (%)。
2）n = d.Count ：把字典中所有的關鍵字的數量賦給變量n。本例得到的是3。
-
② Key 屬性：
在 Dictionary 對象中設置一個 key。
語法：
object.Key(key) = newkey參數：
參數說明 object 必選項?？偸且粋€字典 (Dictionary) 對象的名稱。 key 被改變的 key 值。 newkey 必選項。替換所指定的 key 的新值。 說明：如果在改變一個 key 時沒有發現該 key，那么將創建一個新的 key 并且其相關聯的 item 被設置為空。
常用語句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" d.Key("c") = "d"
代碼詳解：
1）d.Key("c") = "d" ：用新的關鍵字"d"來替換指定的關鍵字"c"，這時，字典中就沒有關鍵字c了，只有關鍵字d了，與d對應的項是"Cairo"。
-
③ Item 屬性：
在一個 Dictionary 對象中設置或者返回所指定 key 的 item。對于集合，則根據所指定的 key 返回一個 item。讀 / 寫。
語法：
object.Item(key)[ = newitem]參數：
參數說明 object 必選項?？偸且粋€Dictionary 對象的名稱。 key 與要被查找或添加的 item 相關聯的 key。 newitem 可選項。僅適用于 Dictionary 對象；newitem 就是與所指定的 key 相關聯的新值。 說明：如果在改變一個 key 的時候沒有找到該 item，那么將利用所指定的 newitem 創建一個新的 key。如果在試圖返回一個已有項目的時候沒有找到 key，那么將創建一個新的 key 且其相關的項目被設置為空。
常用語句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" MsgBox d.Item("c")
代碼詳解：
1）d.Item("c") ：獲取指定的關鍵字"c"對應的項。
2）MsgBox ：是一個 VBA 函數，用消息框顯示。如果要詳細了解MsgBox函數的，可參見我的另一篇文章 常用VBA函數精選合集。
-
④ CompareMode 屬性：
設置或者返回在 Dictionary 對象中進行 字符串關鍵字比較 時所使用的 比較模式。
語法：
object.CompareMode[ = compare]
參數：
參數說明 object 必選項?？偸且粋€Dictionary 對象的名稱。 compare 可選項。如果提供了此項，compare 就是一個代表比較模式的值。
可以使用的值是 0 (二進制)、1 (文本)、 2 (數據庫)。說明：如果試圖改變一個已經包含有數據的 Dictionary 對象的比較模式，那么將導致一個錯誤。
常用語句：
Dim d Set d = CreateObject("Scripting.Dictionary") d.CompareMode = vbTextCompare d.Add "a", "Athens" d.Add "b", "Belgrade" d.Add "c", "Cairo" d.Add " B ", " Baltimore"
代碼詳解：
1）d.CompareMode = vbTextCompare ：設置字典的比較模式是文本，在這種比較模式下 不區分關鍵字的大小寫 ，即關鍵字”b”和”B”是一樣的。vbTextCompare的值為1，所以上式也可寫為 d.CompareMode =1 。如果設置為vbBinaryCompare（值為0），則執行 二進制比較 ，即 區分關鍵字的大小寫，此種情況下關鍵字”b”和”B”被認為是不一樣的。
2）d.Add " B ", " Baltimore" ：添加一關鍵字”B”和對應于它的項”Baltimore”。由于前面已經設置了比較模式為文本模式，不區分關鍵字的大小寫，即關鍵字”b”和”B”是一樣的，此時發生錯誤添加失敗，因為字典中已經存在”b”了，字典中的關鍵字是唯一的，不能添加重復的關鍵字。
-
2. 實例
2.1 實例1. 普通常見的求不重復值問題
2.1.1 問題
表格中人員有很多是重復的，要求編寫一段代碼，把重復的人員姓名以及重復的次數求出來，復制到另一個表格中。
如圖實例1－1所示。
圖 實例1-12.1.2 實例代碼
Sub cfz()Dim i&, Myr&, ArrDim d, k, tSet d = CreateObject("Scripting.Dictionary")Myr = Sheet1.[a65536].End(xlUp).RowArr = Sheet1.Range("a1:g" & Myr)For i = 2 To UBound(Arr)d(Arr(i, 3)) = d(Arr(i, 3)) + 1Nextk = d.keyst = d.itemsSheet2.Activate[a2].Resize(d.Count, 1) = Application.Transpose(k)[b2].Resize(d.Count, 1) = Application.Transpose(t)[a1].Resize(1, 2) = Array("姓名", "重復個數")Set d = Nothing End Sub2.1.3 代碼詳解
Dim i&, Myr&, Arr ：變量i和Myr聲明為長整型變量。 也可以寫為 Dim Myr As Long 。Long的類型聲明字符為(&)。Arr后面沒有寫明數據類型，默認就是可變型數據類型(Variant)。
Set d = CreateObject("Scripting.Dictionary")：創建字典對象，并把字典對象賦給變量d。這是最常用的一句代碼。所謂的“后期綁定”。用了這句代碼就不用先引用c:\windows\system32\scrrun.dll了。
Myr = Sheet1.[a65536].End(xlUp).Row ：把表1的A列最后一行不為空白的行數賦給變量Myr。這里用了Range對象的 End 屬性，它有4個方向參數，此處的xlUp表示向上，它的值為3，所以也可寫成End(3)。xlDown表示向下，它的值為4；xlToLeft表示向左，它的值為1；xlToRight表示向右，它的值為2。
Arr = Sheet1.Range("a1:g" & Myr)：把表1的A1到G列最后一行不為空白的 單元格區域的值賦給變量Arr。這樣Arr就是個 二維數組 了，用數組替代單元格引用可對執行代碼的速度提高很多很多。
For i = 2 To UBound(Arr) ：For…Next 循環結構，從2開始到數組的最大上界值之間循環。因為數組的第一行是表頭。Ubound是VBA函數，返回數組的指定維數的最大可用上界。
d(Arr(i, 3)) = d(Arr(i, 3)) + 1 ：Arr(i,3)在本例是姓名列，也就是關鍵字列，舉個例子，假如Arr(i,3)=”張三”，這句代碼的意思就是把關鍵字”張三”加入字典，d(key)等于關鍵字key對應的項，每出現一次這個關鍵字，它的項的值就增加1。起到了按關鍵字累加的作用，也正因為有這個作用，所以可使用字典來進行各種匯總統計。后面要講的實例會充分的展現這個作用。
k=d.keys ：把字典d中存在的所有的關鍵字賦給變量k。得到的是一個一維數組，下限為0，上限為d.Count-1。Keys是字典的方法，前面已經講過了。
t=d.items ：把字典d中存在的所有的關鍵字對應的項賦給變量t。得到的也是一個一維數組，下限為0，上限為d.Count-1。Items也是字典的方法，前面也已經講過了。
Sheet2.Activate ：激活表2；
[a2].Resize(d.Count, 1) = Application.Transpose(k) ：把字典d中所有的關鍵字賦給以a2單元格開始的單元格區域中。詳細的解釋請見前面的keys方法一節。
[b2].Resize(d.Count, 1) = Application.Transpose(t) ：把字典d中所有的關鍵字對應的項賦給以b2單元格開始的單元格區域中。
[a1].Resize(1, 2) = Array("姓名", "重復個數") ：Array是一個VBA函數，返回一個下界為0的一維數組。一維數組可以看作是水平排列的，所以賦值給水平的單元格區域不需要用轉置函數了。這里作為表頭一次性輸入。
Set d = Nothing ：釋放字典內存。
代碼執行后如圖實例1-2所示。
圖 實例1-2實例1文件：點擊下載????????提取碼：t34n
2.2 實例2 求多表的不重復值問題
2.2.1 問題
一工作簿里面有3張工作表上，每張表格的A列都是姓名列，所有這些姓名中有些是重復的，要求編寫一段代碼，在另一個工作表上顯示不重復的姓名。
如圖實例2－1所示
圖 實例2-1這個問題也很適合用字典來解決。代碼如下：
2.2.2 代碼
Sub bcfz()Dim i&, Myr&, ArrDim d, k, t, Sht As WorksheetSet d = CreateObject("Scripting.Dictionary")For Each Sht In SheetsIf Sht.Name <> "Sheet4" ThenMyr = Sht.[a65536].End(xlUp).RowArr = Sht.Range("a2:a" & Myr)For i = 1 To UBound(Arr)d(Arr(i, 1)) = ""NextEnd IfNextk = d.keysSheet4.[a3].Resize(d.Count, 1) = Application.Transpose(k)Set d = Nothing End Sub2.2.3 代碼詳解
代碼執行后如圖實例2-2所示：
圖 實例2-2實例2文件：點擊下載????????提取碼：snfv
2.3 實例3 A列中顯示1 ~ 1000中被6除余1和余5 的數字
2.3.1 問題
有1、2、3…1000一千個數字，要求編寫一段代碼，在工作表的A列顯示這些數被6除余1和余5的數字。
2.3.2 代碼
Sub 余1余5() ‘by:狼版主Dim dic As Object, i As Long, arrSet dic = CreateObject("Scripting.Dictionary")For i = 1 To 1000dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), ""Nextarr = WorksheetFunction.Transpose(Filter(dic.keys, "@"))[a1].Resize(UBound(arr), 1) = arr[a:a].Replace "@", ""Set dic = Nothing End Sub2.3.3 代碼詳解
Dim dic As Object, i As Long, arr ：也可把字典變量dic聲明為對象(Object)，i As Long是規范的寫法，也可寫成i& 。
dic.Add i & IIf(Abs(i Mod 6 - 3) = 2, "@", ""), "" ：這句代碼的內容比較多，用了兩個VBA函數IIf和Abs，用了一個Mod運算符。i Mod 6就是每一個數除6的余數，題目中有兩個要求：余1和余5，為了從1到1000都同時能滿足這兩個要求，所以用了Abs(i Mod 6 - 3) = 2 ，Abs是取絕對值函數。另一個VBA函數IIf是根據判斷條件返回結果，和If…Then判斷結果類似；IIf(Abs(i Mod 6 - 3) = 2, "@", "") 這段的意思是如果符合判斷條件，返回”@”否則返回空””。 i & IIf(Abs(i Mod 6 - 3) = 2, "@", "")的意思是把這個數與”@”或者""連起來作為關鍵字加入字典dic，關鍵字相對應的項為空。比如當i=1時，1是滿足上述表達式的，就把”1@” 作為關鍵字加入字典dic；當i=2時，2不滿足上述表達式，就把”2” 作為關鍵字加入字典dic，關鍵字相對應的項都為空。
arr = WorksheetFunction.Transpose(Filter(dic.keys, "@")) ：這句代碼的內容分為3部分，第1部分是Filter(dic.keys, "@") 其中的 Filter 是一個 VBA 函數，VBA 函數就是可以直接在代碼中使用的，我們平常使用的函數叫工作表函數，如Sum、Sumif、Transpose 等等。Filter 函數要求在一維數組中篩選出符合條件的另一個一維數組，式中的dic.keys正是一個一維數組。這里的篩選條件是“@”，也就是把字典關鍵字中含有@ 的關鍵字篩選出來組成一個新的一維數組，其下標從零開始。第2部分是用工作表函數 Transpose 轉置這個新的一維數組，工作表函數的使用在前面keys方法一節已經說過了；第2部分是把轉置以后的值賦給數組變量Arr。
~呵呵，狼版主的代碼是短了，我的解釋卻太長了。
[a1].Resize(UBound(arr), 1) = arr ：把數組 Arr 賦給 [a1] 單元格開始的區域中。
[a:a].Replace "@", "" ：把A列中的所有的@都替換為空白，只剩下數字了。
代碼詳解的4代碼執行后，如圖實例3-1所示：
圖實例3-1 示例代碼全部執行后如圖實例3-2所示：
圖實例3-2 示例實例3文件：點擊下載????????提取碼：d2c1
2.4 實例4 拆分數據不重復
2.4.1 問題
有一列各種手機品牌型號的數據，要求編寫一段代碼，按照品牌劃分成沒有重復數據的三大類。
2.4.2 代碼
Sub caifen()Dim Myr&, Arr, x&Dim d, d1, d2, i&, j&Set d = CreateObject("Scripting.Dictionary")Set d1 = CreateObject("Scripting.Dictionary")Set d2 = CreateObject("Scripting.Dictionary")Myr = [a65536].End(xlUp).RowArr = Range("a2:a" & Myr)Range("c2:e" & Myr).ClearContentsmy = Array("MOTO", "諾基亞", "三星", "索愛")gc = Array("OPPO", "聯想", "天語", "金立", "步步高", "波導", "TCL", "酷派")For x = 1 To UBound(Arr)For i = 0 To UBound(my)If InStr(Arr(x, 1), my(i)) > 0 Thend(Arr(x, 1)) = ""GoTo 100End IfNext iFor j = 0 To UBound(gc)If InStr(Arr(x, 1), gc(j)) > 0 Thend1(Arr(x, 1)) = ""GoTo 100End IfNext jd2(Arr(x, 1)) = ""100:Next xRange("c2").Resize(UBound(d.keys) + 1, 1) = Application.Transpose(d.keys)Range("d2").Resize(UBound(d1.keys) + 1, 1) = Application.Transpose(d1.keys)Range("e2").Resize(UBound(d2.keys) + 1, 1) = Application.Transpose(d2.keys) End Sub2.4.3 代碼詳解
代碼執行后如圖實例4-1所示：
圖 實例4-1 示例山菊花版主用了一個字典對象就解決了上述問題。讓我們來學習一下：
2.4.4 山菊花版主的代碼
Sub 拆分()Dim pp1$, pp2$, nRow%, ds, Brr(), s(1 To 3) As IntegerSet ds = CreateObject("scripting.dictionary")pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDown))), ",")pp2 = Join(WorksheetFunction.Transpose(Range(Range("h2"), Range("h1").End(xlDown))), ",")nRow = Range("a1").End(xlDown).RowArr = Range("a1:a" & nRow)ReDim Brr(1 To nRow, 1 To 3)For i = 2 To nRowIf Not ds.Exists(Arr(i, 1)) Thends(Arr(i, 1)) = ""If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Thens(1) = s(1) + 1Brr(s(1), 1) = Arr(i, 1)ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Thens(2) = s(2) + 1Brr(s(2), 2) = Arr(i, 1)Elses(3) = s(3) + 1Brr(s(3), 3) = Arr(i, 1)End IfEnd IfNextRange("c2:e" & nRow) = Brr End Sub2.4.5 代碼詳解
pp1 = Join(WorksheetFunction.Transpose(Range(Range("g2"), Range("g1").End(xlDown))), ",")
這句代碼用了兩個 VBA 函數 Join 和 Transpose ，Range("g1").End(xlDown)從G1單元格往下直到最下面的單元格，遇到空白格就停止。因為本例的G14、G15單元格有另外的數據存在，如果還是用Range("g65536").End(xlUp)，那么就會把不需要的數據帶進去，造成結果出錯。Transpose 轉置函數，前面已經介紹過了。Join函數是通過連接某個數組中的多個子字符串而創建的一個字符串，本句代碼執行后得到：
????????pp1 = “MOTO, 諾基亞, 三星, 索愛”；
????????pp2 一句同上句一樣，得到另一個字符串。
nRow = Range("a1").End(xlDown).Row ：把A列最后一行不為空白的行數賦給整型變量nRow。
Arr = Range("a1:a" & nRow) ：把A列A1開始的有數據的單元格區域賦給變量Arr。
ReDim Brr(1 To nRow, 1 To 3) ：用于為動態數組變量Brr重新分配存儲空間。第一維的下界從1到上界nRow，第二維從1到3。
For i = 2 To nRow ：從2到 nRow逐一循環。
If Not ds.Exists(Arr(i, 1)) Then ：如果字典ds中不存在關鍵字Arr(i, 1)
ds(Arr(i, 1)) = "" ：把Arr(i, 1)作為關鍵字加入字典ds。
If pp1 Like "*" & Left(Arr(i, 1), 2) & "*" Then ：這里山版主用了比較運算符Like來比較pp1和取自Arr(i, 1)左邊兩個字符，再在前后加任意字符組成的字符串，如果滿足條件為真，那么執行下面的語句。
s(1) = s(1) + 1 ：數組s的第一個元素+1以后賦給數組s的第一個元素。
Brr(s(1), 1) = Arr(i, 1) ：把這個關鍵字賦給 第2維 為1的另一個數組Brr，也就是我們要求的貿易機類。pp1字符串里都是貿易機類的品牌。
ElseIf pp2 Like "*" & Left(Arr(i, 1), 2) & "*" Then ：同樣，如果滿足國產品牌類這個條件，那么執行下面的代碼。
s(2) = s(2) + 1 ：數組s的第二個元素+1以后賦給數組s的第二個元素。
Brr(s(2), 2) = Arr(i, 1) ：把這個關鍵字賦給 第2維 為2的另一個數組Brr，也就是我們要求的國產品牌類。pp2字符串里都是國產品牌類的品牌。
s(3) = s(3) + 1 ：前如果條件都不滿足時，數組s的第三個元素+1以后賦給數組s的第三個元素。
Brr(s(3), 3) = Arr(i, 1) ：把這個關鍵字賦給 第3維 為1的另一個數組Brr，也就是我們要求的其它品牌類。
Range("c2:e" & nRow) = Brr ：把數組Brr賦給[c2]單元格開始的區域中。
實例4文件：點擊下載????????提取碼：nrhi
2.5 實例5 前期綁定的字典實例
2.5.1 問題
有多列多行數據，其中有重復的行，要求編寫一段代碼，求得不重復的行數據。
如圖實例5-1所示：
圖 實例5-1 示例2.5.2 代碼
Sub 保留原數據() 'by:ldy888'前期綁定，需先引用c:\windows\system32\scrrun.dllDim d As New Dictionary,tFor i = 2 To 5Set d(Cells(i, 1) & "") = Range(Cells(i, 1), Cells(i, 4))Nextt=d.items [A11].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(t)) End Sub2.5.3 代碼詳解
Dim d As New Dictionary, t ：本段代碼需要先引用微軟的腳本運行時庫 Microsoft Scripting Runtime，可在 VBE 窗口，從菜單－工具－引用，然后勾選Microsoft Scripting Runtime，或者點擊瀏覽，在添加引用對話框中選擇c:\windows\system32\scrrun.dll，并打開，確定。完成引用。在本聲明語句中把字典d聲明為New Dictionary。這就是 “ 前期綁定 ” 了。上面的實例用的是創建對象語句：
Set d = CreateObject("Scripting.Dictionary")，稱為 “ 后期綁定 ” ，不需要先引用腳本運行時庫。
Set d(Cells(i, 1) & "") = Range(Cells(i, 1), Cells(i, 4))：把單元格對象加入字典，它對應的項是同一行的單元格區域。注意，這里用了Set，和前面的幾例不一樣哦。如果用 Typename(d(Cells(i,1) & ""))，得到的是一個Range對象。這里的Cells(i, 1) & ""也可以用Cells(i, 1).Value來代替。
t=d.items ：把字典d中存在的所有的關鍵字對應的項賦給變量t。得到的是一個一維數組，下限為0，上限為d.Count-1。
[A11].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(t)) ：這句用了兩次工作表轉置函數Transpose之后賦給A11單元格開始的區域中。
代碼執行后如圖實例5-2所示：
圖 實例5-2示例實例5文件：點擊下載????????提取碼：kr3o
2.6 實例6 多條件復雜匯總
2.6.1 問題
有一個表格，需要對其中多個條件相同的數量進行合并匯總，并且要有匯總的明細數據，要求編寫一段代碼，實現這樣的合并同類項的要求。
2.6.2 代碼
Sub kf2() ‘by:oobirdDim d As Object, a, b, j%, w!Dim ss$, n%, xMe.UsedRange.Offset(3, 0) = ""a = Sheet1.Range(Sheet1.[a4], Sheet1.[i65536].End(xlUp))Set d = CreateObject("scripting.dictionary")ReDim b(1 To UBound(a), 1 To 8)For i = 1 To UBound(a)ss = a(i, 1) & a(i, 2) & a(i, 4) & a(i, 5) & a(i, 6) & a(i, 8) If Not d.Exists(ss) Thenn = n + 1d.Add ss, nb(n, 1) = a(i, 2): b(n, 2) = a(i, 5): b(n, 3) = a(i, 6): b(n, 4) = a(i, 4)b(n, 5) = a(i, 1): b(n, 6) = a(i, 8): b(n, 7) = a(i, 9)Elseb(d(ss), 7) = b(d(ss), 7) & "+" & a(i, 9)End IfNextFor i = 1 To d.Countx = Split(b(i, 7), "+")For j = 0 To UBound(x)w = w + x(j)Next jb(i, 8) = b(i, 5) * b(i, 6) * w / 100: w = 0Next[b4].Resize(n, 8) = b End Sub2.6.3 代碼詳解
代碼執行后如圖實例6-1所示：
實例 6 文件：點擊下載????????提取碼：ytp6
2.7 實例7 字典法排序
2.7.1 問題
A列B列是按順序排列的全部股票代碼和股票名稱，C列D列和E列F列是另外按條件篩選出來的無序的數據， 要求編寫一段代碼，將它們排列到與A列相同的股票行里面。
代碼執行前如圖實例7-1所示：
圖 實例7-1示例2.7.2 代碼
Private Sub CommandButton1_Click() ‘by:oobirdDim d As Object, rng, i%, j%, arrSet d = CreateObject("Scripting.Dictionary")rng = Range("a3:f" & [a65536].End(xlUp).Row)ReDim arr(1 To UBound(rng), 1 To 4)For i = 1 To UBound(rng) d(CStr(rng(i, 1))) = iNext iFor j = 3 To 5 Step 2For i = 1 To Cells(65536, j).End(xlUp).Row - 2If d(CStr(rng(i, j))) <> "" Thenarr(d(CStr(rng(i, j))), j - 2) = rng(i, j) arr(d(CStr(rng(i, j))), j - 1) = rng(i, j + 1)End IfNext iNext j[c3].Resize(UBound(rng), 4) = arr End Sub2.7.3 代碼詳解
代碼執行后如圖實例7-2所示：
圖 實例7-2示例實例 7 文件：點擊下載????????提取碼：3ijp
2.8 實例8 2級動態數據有效性問題
2.8.1 問題
A列是源名稱，中間有空格，B列為各個源名稱對應的數目不同的代號，C列是目標名稱來源于源名稱，要求在C列設置不重復的、沒有空格的數據有效性供選擇；同時D列目標代號，要求隨著C列選擇的目標名稱的不同，提供對應的代號供選擇，是為第2級數據有效性。
代碼執行前如圖實例8-1所示：
圖 實例8-1示例2.8.2 代碼
Private Sub Worksheet_SelectionChange(ByVal Target As Range)If Target.Count > 1 Then Exit SubIf Target.Column <> 4 And Target.Column <> 3 Then Exit SubDim d, i&, Myr&, Arr, r%, Arr1(), cp$, ks&, js&, j&Set d = CreateObject("Scripting.Dictionary")Myr =[b65536].End(xlUp).RowArr = Range("a2:b" & Myr)If Target.Column = 3 ThenFor i = 1 To UBound(Arr)If Arr(i, 1) <> "" Thend(Arr(i, 1)) = ""End IfNextWith Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=Join(d.keys, ",")End WithTarget.Offset(0, 1) = ""ElseIf Target.Column = 4 And Target.Offset(0, -1) <> "" ThenFor i = 1 To UBound(Arr)If Arr(i, 1) <> "" Thenr = r + 1ReDim Preserve Arr1(1 To r)Arr1(r) = iEnd IfNext iFor i = 1 To rIf Arr(Arr1(i), 1) = Target.Offset(0, -1).Text ThenIf i <> r Thenjs = Arr1(i + 1) - 1Elsejs = Myr - 1End Ifks = Arr1(i)For j = ks To jscp = cp & Arr(j, 2) & ","NextEnd IfNext icp = Left(cp, Len(cp) - 1)With Target.Validation.Delete.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _Operator:=xlBetween, Formula1:=cpEnd WithTarget = Split(cp, ",")(0)End IfSet d = Nothing End Sub2.8.3 代碼詳解
代碼執行后如圖實例8-2所示：
圖 實例8-2示例實例 8 文件：點擊下載????????提取碼：lzh7
2.9 實例9 字典取行數，數組重新賦值
2.9.1 問題
要求編寫一段代碼，求得B列不重復的名字，其相應的A列和D列分別用" "連起來，而相應的E列F列的數值分別相加匯總。
代碼執行前如圖實例9-1所示。
圖 實例9-1示例：
2.9.2 代碼
Sub yy() 'by:ZamyiDim d As New Dictionary, RDim k, i&, j&R = Sheet1.UsedRangek = 1For i = 2 To UBound(R)R(i, 2) = Replace(Replace(R(i, 2), "（", "("), "）", ")")If d.Exists(R(i, 2)) ThenR(d(R(i, 2)), 1) = R(d(R(i, 2)), 1) & " " & R(i, 1)R(d(R(i, 2)), 4) = R(d(R(i, 2)), 4) & " " & R(i, 4)R(d(R(i, 2)), 5) = Val(R(d(R(i, 2)), 5)) + R(i, 5)R(d(R(i, 2)), 6) = Val(R(d(R(i, 2)), 6)) + R(i, 6)Elsek = k + 1d(R(i, 2)) = iFor j = 1 To UBound(R, 2)R(k, j) = R(i, j)NextEnd IfNextWith Sheet2.Cells.ClearContents.Cells.Borders.LineStyle = xlNone.[a1:F1].Resize(d.Count + 1) = R.[a1:F1].Resize(d.Count + 1).Borders.LineStyle = 1End WithSet d = Nothing End Sub2.9.3 代碼詳解
代碼執行后如圖實例9-2所示：
圖 實例9-2示例實例 9 文件：點擊下載????????提取碼：har1
2.10 實例10 先字典求得行后顯示整行數據
2.10.1 問題
有3列數據，要求編寫一段代碼，如果C列名次、A列主排相同時，根據B列次排最大的只保留一行。
解題思路：先對3列數據按主要關鍵字名次_升序，次要關鍵字主排_升序，第3關鍵字次排_降序進行排序，然后運用字典，以”名次|主排” 作為關鍵字，它所在的行作為關鍵字的項加入字典，最后根據行引用相對的單元格值。
代碼執行前如圖實例10-1所示：
圖 實例10-1示例2.10.2 代碼
Sub pmc()Dim i&, Myr&, ArrDim d, x, rngApplication.ScreenUpdating = FalseSet d = CreateObject("Scripting.Dictionary")Sheet1.ActivateMyr = [a65536].End(xlUp).RowRange("A1:C" & Myr).Sort Key1:=Range("C2"), Order1:=xlAscending, Key2:=Range( _"A2"), Order2:=xlAscending, Key3:=Range("B2"), Order3:=xlDescending, _Header:=xlYesArr = Range("a2:c" & Myr)For i = 1 To UBound(Arr)x = Arr(i, 1) & "|" & Arr(i, 3)If Not d.exists(x) Thend.Add x, i + 1End IfNext[e:g].ClearContents[e2].Resize(d.Count, 1) = Application.Transpose(d.items)For Each rng In [e2].Resize(d.Count, 1)rng.Resize(1, 3) = Cells(rng, 1).Resize(1, 3).ValueNextSet d = NothingApplication.ScreenUpdating = True End Sub2.10.3 代碼詳解
代碼執行后如圖實例10-2所示：
圖 實例10-2示例實例 10 文件：點擊下載????????提取碼：92ie
2.11 實例11 關鍵字賦給兩列后用Replace方法
2.11.1 問題
有如圖實例11-1所示的工資表，要求編寫一段代碼，運用VBA自動生成1季度的工資表。
解題思路：先把性別和姓名連起來作為關鍵字求得人員的不重復值，然后通過循環查找關鍵字獲得其各月的工資，最后用Replace方法替換兩列關鍵字區域得到各自的數據。
代碼執行前如圖實例11-1所示：
圖 實例11-1示例2.11.2 代碼
Sub yy()Dim d, k, t, i&, j&, Arr, x, r1Set d = CreateObject("Scripting.Dictionary")Arr = [a1].CurrentRegionFor i = 1 To UBound(Arr, 2) Step 3For j = 2 To UBound(Arr)If Arr(j, i) <> "" Thenx = Arr(j, i) & "|" & Arr(j, i + 1)d(x) = ""End IfNextNextk = d.keys[a12:i1000].ClearContents[a13].Resize(d.Count, 2) = Application.Transpose(k)[a12:b12] = Array("性別", "姓名")For i = 3 To UBound(Arr, 2) Step 3Cells(12, 2 + i / 3) = Cells(1, i)NextFor i = 3 To UBound(Arr, 2) Step 3For j = 2 To UBound(Arr)If Arr(j, i) <> "" Thenx = Arr(j, i - 2) & "|" & Arr(j, i - 1)Set r1 = [a13].Resize(d.Count, 1).Find(x, , , 1)Cells(r1.Row, 2 + i / 3) = Arr(j, i)End IfNextNext[a13].Resize(d.Count, 1).Replace "|*", "", xlPart[b13].Resize(d.Count, 1).Replace "*|", "", xlPart End Sub2.11.3 代碼詳解
代碼執行后如圖實例11-2所示：
圖 實例11-2示例實例 10 文件：點擊下載????????提取碼：x4sb
2.12 實例12 復雜報表匯總
2.12.1 問題的提出 ：
有一日報表，里面有生產型號、生產數量、返修原因、返修數量、報廢原因、報廢數量，要求編寫一段代碼，按同型號產品匯總生產數量；得到同型號產品相同返修原因的唯一值；按同型號產品相同返修原因匯總返修數量； 得到同型號產品相同報廢原因的唯一值；同型號產品相同報廢原因匯總報廢數量，并且合并相同內容的單元格。
代碼執行前如圖實例12-1所示：
圖 實例12-1示例2.12.2 代碼
Sub bbhz()Dim i&, Myr&, x(1 To 3), Arr, n%, aa, j&, Arr1(), r%, Arr2(), r2%, r3%, Arr3()Dim d(1 To 3) As New dictionary, k(1 To 3), t(1 To 3), js, ks, ii%, jj&, ks1, js1Application.ScreenUpdating = FalseMyr = Sheet1.[a65536].End(xlUp).RowArr = Sheet1.Range("a3:g" & Myr)For i = 1 To UBound(Arr)x(1) = Arr(i, 2)d(1)(x(1)) = d(1)(x(1)) + Arr(i, 3)x(2) = Arr(i, 2) & "|" & Arr(i, 4)d(2)(x(2)) = d(2)(x(2)) + Arr(i, 5)x(3) = Arr(i, 2) & "|" & Arr(i, 4) & "|" & Arr(i, 6)d(3)(x(3)) = d(3)(x(3)) + Arr(i, 7)NextFor i = 1 To 3k(i) = d(i).Keyst(i) = d(i).ItemsNextSheet4.Activate[a3:k1000].ClearContents[a3:k1000].UnMerge[a3:k1000].Borders.LineStyle = xlNone[i3].Resize(d(3).Count, 1) = Application.Transpose(t(3))n = 2For i = 0 To UBound(k(3))aa = Split(k(3)(i), "|")n = n + 1Cells(n, 2) = aa(0)Cells(n, 4) = aa(1)Cells(n, 8) = aa(2)NextFor i = 3 To nFor j = 0 To UBound(k(1))If Cells(i, 2) = k(1)(j) ThenCells(i, 3) = t(1)(j)Cells(i, 10) = Cells(i, 9) / Cells(i, 3)Cells(i, 11) = Cells(i, 10): Exit ForEnd IfNextFor j = 0 To UBound(k(2))If Cells(i, 2) & "|" & Cells(i, 4) = k(2)(j) ThenCells(i, 5) = t(2)(j)Cells(i, 6) = Cells(i, 5) / Cells(i, 3)Cells(i, 7) = Cells(i, 6): Exit ForEnd IfNextNextRange("a3:k" & n).Sort Key1:=Range("b3"), Order1:=xlAscending, Key2:=Range("d3") _, Order2:=xlAscending, Key3:=Range("h3"), Order3:=xlAscending, Header:= _xlGuessFor i = 3 To nIf Cells(i, 2) <> Cells(i - 1, 2) Thenr = r + 1ReDim Preserve Arr1(1 To r)Arr1(r) = iEnd IfNextApplication.DisplayAlerts = FalseFor j = 1 To rr3 = 0: r2 = 0If j <> r Thenjs = Arr1(j + 1) - 1Elsejs = nEnd Ifks = Arr1(j)If js - ks + 1 > 1 ThenCells(ks, 1).Resize(js - ks + 1, 1).MergeCells(ks, 2).Resize(js - ks + 1, 1).MergeCells(ks, 3).Resize(js - ks + 1, 1).MergeEnd IfCells(ks, 1) = jFor ii = ks To jsIf ii = ks Thenr2 = r2 + 1ReDim Preserve Arr2(1 To r2)Arr2(r2) = iiElseIf Cells(ii, 4) <> Cells(ii - 1, 4) Thenr2 = r2 + 1ReDim Preserve Arr2(1 To r2)Arr2(r2) = iiEnd IfNextFor ii = 1 To r2If ii <> r2 Thenjs1 = Arr2(ii + 1) - 1Elsejs1 = jsEnd Ifks1 = Arr2(ii)If js1 - ks1 + 1 > 1 ThenCells(ks1, 4).Resize(js1 - ks1 + 1, 1).MergeFor jj = ks1 To js1If jj <> ks1 ThenCells(ks, 7) = Cells(ks, 7) + Cells(jj, 7)End IfNextCells(ks1, 5).Resize(js1 - ks1 + 1, 1).MergeCells(ks1, 6).Resize(js1 - ks1 + 1, 1).MergeElseIf ii <> 1 ThenCells(ks, 7) = Cells(ks, 7) + Cells(ks1, 7)End IfEnd IfNextCells(ks, 7).Resize(js - ks + 1, 1).MergeFor ii = ks To jsIf ii = ks Thenr3 = r3 + 1ReDim Preserve Arr3(1 To r3)Arr3(r3) = iiElseIf Cells(ii, 8) <> Cells(ii - 1, 8) Thenr3 = r3 + 1ReDim Preserve Arr3(1 To r3)Arr3(r3) = iiEnd IfNextFor ii = 1 To r3If ii <> r3 Thenjs1 = Arr3(ii + 1) - 1Elsejs1 = jsEnd Ifks1 = Arr3(ii)If js1 - ks1 + 1 > 1 ThenCells(ks1, 8).Resize(js1 - ks1 + 1, 1).MergeFor jj = ks1 To js1If jj <> ks1 ThenCells(ks1, 9) = Cells(ks1, 9) + Cells(jj, 9)Cells(ks1, 10) = Cells(ks1, 10) + Cells(jj, 10)End IfCells(ks, 11) = Cells(ks, 11) + Cells(jj, 11)NextCells(ks1, 9).Resize(js1 - ks1 + 1, 1).MergeCells(ks1, 10).Resize(js1 - ks1 + 1, 1).MergeElseIf ii <> 1 ThenCells(ks, 11) = Cells(ks, 11) + Cells(ks1, 11)End IfEnd IfNextCells(ks, 11).Resize(js - ks + 1, 1).MergeNextRange("a3:k" & n).Borders.LineStyle = 1Application.DisplayAlerts = TrueApplication.ScreenUpdating = True End Sub2.12.3 代碼詳解
代碼執行后如圖實例12-2所示：
圖 實例12-2示例實例 12 文件：點擊下載????????提取碼：z3ob
3. 后語
????????常見字典用法實例集錦到此告一段落了。字典就象一個二維數組Arr(1 to n,1 to 2)，不過它的第 2 維的最大上界為 2，相當于2列單元格，第1列存放的是關鍵字，這個關鍵字是除了數組以外的任何類型；第2列存放的是這個關鍵字對應的項，它可以是數據的任何類型。
????????我收集的和接觸到有關字典的實例的數量有限，一定會有更好更有代表性的實例沒有接觸到，希望有心人能提供出來，供大家學習分享。
????????謝謝大家！
總結
以上是生活随笔為你收集整理的常见字典用法集锦及代码详解的全部內容，希望文章能夠幫你解決所遇到的問題。
- 上一篇： html5点击效果文字跳转,JS网页特效
- 下一篇： 三层架构 详解