創建字典對象
'后期綁定：方便代碼在其他電腦上運行，推薦。
dim dic as object
Set dic = CreateObject("scripting.dictionary")
'前期綁定：可以直接聲明字典對象，有對象屬性和方法的提示，但在其他沒有勾選引用的電腦上無法正常運行。
'引用勾選：VBE窗體-工具-引用-勾選‘Microsoft Scripting Runtime’
dim dic as New dictionary
1
2
3
4
5
6
7
獲取字典的鍵、值，字典計數，刪除，判斷鍵是否存在於字典
with activesheet
'dic.count：字典計數，字典中一共有多少條記錄；
'dic.keys：字典的鍵，寫入單元格以行寫入，如需以列寫入單元格，調用工作表函數transpose轉置；
.cells(1,1).resize(dic.count,1) = application.worksheetfunction.transpose(dic.keys)
'清除工作表單元格內容
.cells.clearcontents
'dic.items：字典的值；
.cells(1,1).resize(1,dic.count) = dic.items
'判斷某內容是否存在與字典的鍵中
if dic.exists("內容") then debug.print "字符串‘內容’存在於字典的鍵中"
'清空字典，有時候其他過程也需要使用字典，當前過程已經使用完了，但我們又不想重新創建字典對象，這時候我們可以public字典全局變量，再清空字典，供新的過程使用該字典對象。
dic.removeall
'清除單個字典鍵-值對,key是字典的某個需要刪除的鍵
dic.remove key
end with
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
字典常用方法
去重
dim dic as object
dim arr
dim st
Set dic = CreateObject("scripting.dictionary")
arr = array("可樂","雪碧","雞翅",,"可樂","漢堡包","雞翅")
for each st in arr
'字典的鍵是不能重復的，重復導入字典只會存在一個，可以利用字典這點特性去重。
'這里不需要字典的值，設置為空字符串或其他數值都可以。
dic(st) = ""
next
activesheet.range("a1").resize(dic.count,1) = application.worksheetfunction.transpose(d.keys)
1
2
3
4
5
6
7
8
9
10
11
12
實現sumifs條件求和
Sub dic_sumif()
Application.ScreenUpdating = False
Dim dic As Object
Dim arr
Dim i As Byte
Set dic = CreateObject("scripting.dictionary")
With ActiveSheet
arr = .UsedRange
For i = 2 To UBound(arr)
'dic(arr(i,1))沒有值是默認是0，通過下面方法對每一個水果的銷量進行累加。
dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 2)
Next
'使用copy方法，將表頭復制到e1，f1單元格
.Range("a1:b1").Copy .Range("e1")
'字典鍵去重縱向寫入到單元格
.Cells(2, "e").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(dic.keys)
For i = 2 To dic.Count + 1
'循環輸入字典鍵對應的值到f列
.Cells(i, "f").Value2 = dic(.Cells(i, "e").Value2)
Next
End With
set dic = Nothing
Application.ScreenUpdating = True
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
效果如下圖：
3. 計數
如果對上面水果種類進行計數：countifs，只需要將分類匯總的值改為數值1即可，每出現一次‘+1’
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
'在上面代碼中添加下這條，修改下表頭
range("f1").value2 = "計數"
1
2
3
4
效果如下圖：
4. 匹配
這個應該是使用字典應用最多的了，需要注意的是，如果使用單元格寫入到字典，單元格同時也包含格式等信息，如果只需要單元格的值，要使用單元格.value2方法，同時，字典的值也可以是數組。
數據源：
目標：匹配‘李白’和‘后羿’的身高和體重
代碼如下：
Sub data_match()
Application.ScreenUpdating = False
Dim dic As Object
Dim arr
Dim i As Byte
Set dic = CreateObject("scripting.dictionary")
With ActiveSheet
arr = .Cells(1, 1).CurrentRegion
For i = 2 To UBound(arr)
'這里字典的值，用的是array數組，方便我們一下匹配多個數據，省去再創建字典對象麻煩。
dic(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))
Next
For i = 2 To .Cells(1, "e").End(xlDown).row
.Cells(i, "f").Resize(1, 2) = dic(.Cells(i, "e").Value2)
Next
End With
set dic = Nothing
Application.ScreenUpdating = True
End Sub
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
效果如下：
我在這里加入了‘妲己’，遍歷用字典去匹配了，但是字典並沒有‘妲己’這個key，匹配出來是空，並沒有報錯，大家不用擔心字典沒有對應key匹配而出錯這種情況，這樣只會將結果輸出為空。~
如果需要匹配的姓名后面有之前填寫的身高和體重信息，但是載入字典的數據源並沒有這個人的信息，我們在遍歷匹配時，又不想使身高和體重被替換為空，這時候可以結合dic.exisst語句，判斷姓名是否存在於字典的keys中，再輸出匹配結果。
5. key的組合和分割
dim arr
dim i,row as long
dim d as object
dim key
set d = createobject("scripting.dictionary")
with thisworkbook
arr = .sheets(1).usedrange
for i = 2 to ubound(arr)
d(join(array(arr(i,1),arr(i,2),arr(i,3)),"|")) = arr(i,4)
next
with .sheets("輸出")
row = 2
for each key in d.keys
.cells(row,4).value = d(key)
.cells(row,1).resize(1,3) = split(key,"|")
row = row + 1
next
end with
end with
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
字典多字段累加
Sub game_type_active_pay()
Dim file_directory, f As String
Dim i, last_row As Long
Dim d As Object
Dim wb As Workbook
Dim arr
Dim active_uv, pay_uv As Long
Dim pay As Double
Application.ScreenUpdating = False
file_directory = ThisWorkbook.Path & "/data/"
f = Dir(file_directory & "*細分品類*")
'未找到數據源，提示，關閉應用
If f = "" Then
MsgBox "未找到命名包含‘細分品類’文字數據源，請先下載數據源......"
Application.ScreenUpdating = True
End
End If
Set wb = Workbooks.Open(file_directory & f)
Set d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
'On Error Resume Next
For i = 2 To UBound(arr)
If InStr("回流用戶|留存用戶|新增用戶", arr(i, 4)) > 0 Then
If arr(i, 3) = "類型1" Then arr(i, 3) = "類型2" '將類型1合並為類型2
If d.exists(arr(i, 1) & "|" & arr(i, 3)) Then
active_uv = d(arr(i, 1) & "|" & arr(i, 3))(0)
pay_uv = d(arr(i, 1) & "|" & arr(i, 3))(1)
pay = d(arr(i, 1) & "|" & arr(i, 3))(2)
'活躍累加
active_uv = active_uv + arr(i, 6)
pay_uv = pay_uv + arr(i, 7)
pay = pay + arr(i, 8)
d(arr(i, 1) & "|" & arr(i, 3)) = Array(active_uv, pay_uv, pay)
Else
d(arr(i, 1) & "|" & arr(i, 3)) = Array(arr(i, 6), arr(i, 7), arr(i, 8))
End If
End If
Next
'On Error GoTo 0
wb.Close False
Set wb = Nothing
MsgBox d.Count
With ThisWorkbook.Sheets("表名")
arr = .UsedRange
For i = 2 To UBound(arr)
If d.exists(arr(i, 1) & "|" & arr(i, 2)) Then
'如果新的數據源里存在該條記錄，則用新的數據源覆蓋
.Cells(i, 3).Resize(1, 3) = d(arr(i, 1) & "|" & arr(i, 2))
.Cells(i, 6).Value2 = .Cells(i, 5).Value2 / .Cells(i, 3).Value2
d.Remove arr(i, 1) & "|" & arr(i, 2)
End If
Next
last_row = .Cells(Rows.Count, 1).End(xlUp).Row + 1
'將新的記錄寫入到數據源
For Each Key In d.keys
.Cells(last_row, 1).Resize(1, 2) = Split(Key, "|")
.Cells(last_row, 3).Resize(1, 3) = d(Key)
.Cells(last_row, 6).Value2 = .Cells(i, 5).Value2 / .Cells(i, 3).Value2
last_row = last_row + 1
Next
End With
Application.ScreenUpdating = True
End Sub
————————————————
版權聲明：本文為CSDN博主「me_to_007」的原創文章，遵循CC 4.0 BY-SA版權協議，轉載請附上原文出處鏈接及本聲明。
原文鏈接：https://blog.csdn.net/me_to_007/java/article/details/89789378