VBA字典（详解，示例）

文章目录

- 创建字典对象
- 字典的属性|方法
- 案例
- - 去重
  - 求和
  - 计数
  - 匹配
  - key的组合和分割
  - 字典value多字段累加
  - 字典求和和计数同时进行
  - 类似sql的join操作

创建字典对象

'后期绑定：方便代码在其他电脑上运行，推荐。
dim dic as object
Set dic = CreateObject("scripting.dictionary")'前期绑定：可以直接声明字典对象，有对象属性和方法的提示，但在其他没有勾选引用的电脑上无法正常运行。
'引用勾选：VBE窗体-工具-引用-勾选‘Microsoft Scripting Runtime’
dim dic as New dictionary' 字段生成键值对 key-value
key = "姓名"
value = "身高"
dic(key) = value

字典的属性|方法

键：dic.keys返回字段的键，字典的键唯一不可变，不能是数组array；如果想整合多个值，可以将多个值用分隔符拼接成一个字符串作为key
值：dic.items返回字段的值，是一个数组，如果写入单元格体现为一行
键值对条数：dic.count返回字典的键值对数
判断是否存在键key：dic.exists(key)返回true或者false
清空字典键值对：dic.removeall
删除键为key的键值对：dic.remove key
删除字典对象：set dic = Nothing
键值对写入：将键值对写入到字典对象dic.add key,value，使用add方法，如果key重复会报错，因为字典的key不能重复，新增抛出已经存在异常；使用d(key)=value写入不会报错，value会覆盖原来的值。

在这里插入图片描述

我们写入一段代码：

Sub dic()
Application.ScreenUpdating = FalseDim d As ObjectSet d = CreateObject("scripting.dictionary")  ' 创建字典对象' 没有麻子这个key，输入麻子的value是empty对象，如果与字符串合并，这个初始值是空字符串
c = d("麻子")
Debug.Print "1. 麻子的身高是：" & d("麻子")
' 如果与数值相加，这个初始值为0，
Debug.Print "2. 麻子的身高是：" & d("麻子") + 173
Debug.Print "3. 麻子的身高是：" & d("麻子") & "hahaha"d.Add Range("a2").Value2, Range("b2").Value2  ' 增加键值对If d.exists("张三") ThenDebug.Print "4.如果字点存在‘张三’的键，打印张三的身高:" & d("张三")
End Ifd.Add [a3].Value2, [b3].Value2
Debug.Print "5. 李四的身高是:" & d("李四")
d([a4].Value2) = [b4].Value2
Debug.Print "6. 李四的身高是:" & d("李四")d.Add Cells(5, 1), Cells(5, 2)
Debug.Print "7. 王五的身高是：" & d("王五")
Debug.Print "8. 王五的key没有对应的值，应为这里字段传入的是单元格对象：cells(5,1)而不是单元格的值，单元格还会包含格式其他"d.Add Range("a6").Value2, Range("b6").Value2  ' 这里会报错，因为张三的key已经存在了
Debug.Print "9. 张三的身高是:" & d("张三")'清除工作表单元格内容
Cells.ClearContents
'dic.count：字典计数，字典中一共有多少条记录；
'dic.keys：字典的键，写入单元格以行写入，如需以列写入单元格，调用工作表函数transpose转置；' 以列写入
Cells(1, 1).Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)' 以行写入
Cells(1, 2).Resize(1, d.Count) = d.keysd.Remove "王五"    ' 删除key-王五d.RemoveAll    ' 删除所有keySet d = NothingApplication.ScreenUpdating = False
End Sub

先运行下，看发生了什么，报错了

在这里插入图片描述

点击调试，定位到异常语句：使用d.add方法添加键值对，如果key重复会抛出异常

在这里插入图片描述

我们把这行代码删除，按快捷键F8调试，逐行运行看看变量情况；打开VB开发页面，在视图选项卡勾选立即窗口和本地窗口

在这里插入图片描述

Dim d As Object定义变量，变量d是一个objectt

在这里插入图片描述

Set d = CreateObject("scripting.dictionary") ' 创建字典对象定义字典对象，d的类型发生变化

在这里插入图片描述

c = d("麻子")没有麻子这个key，输入麻子的value是Empty对象，如果与字符串合并，这个初始值是空字符串

' 如果与数值相加，这个初始值为0，
Debug.Print "1. 麻子的身高是：" & d("麻子")
Debug.Print "2. 麻子的身高是：" & d("麻子") + 173
Debug.Print "3. 麻子的身高是：" & d("麻子") & "hahaha"

在这里插入图片描述

d.Add Range("a2").Value2, Range("b2").Value2  ' 增加键值对，张三-170
If d.exists("张三") ThenDebug.Print "4.如果字点存在‘张三’的键，打印张三的身高:" & d("张三")
End If

字段存在"张三的键，所以执行了if后的语句

在这里插入图片描述

d.Add [a3].Value2, [b3].Value2
Debug.Print "5. 李四的身高是:" & d("李四")
d([a4].Value2) = [b4].Value2   ' 重新写入李四键值对，李四的值更新成199
Debug.Print "6. 李四的身高是:" & d("李四")

在这里插入图片描述

d.Add Cells(5, 1), Cells(5, 2)
Debug.Print "7. 王五的身高是：" & d("王五")
Debug.Print "8. 王五的key没有对应的值，因为这里字段传入的是单元格对象：cells(5,1)而不是单元格的值，单元格还会包含格式其他"

打印王五的值，没有。"王五"是一个字符串，而cells(5,1)是一个单元格，两个key不同。存在字典键是单元格对象的，将字典的keys或者items写入到单元格会报错；该语句仅供测试，体现字典的key不仅可以是值也可以是单元格对象。

在这里插入图片描述
修改为d.Add Cells(5, 1).value2, Cells(5, 2).value2

Cells.ClearContents
清除所有单元格的值，工作表的数据都被清空了

在这里插入图片描述

'dic.count：字典计数，字典中一共有多少条记录；
'dic.keys：字典的键，写入单元格以行写入，如需以列写入单元格，调用工作表函数transpose转置；' 以列写入
Cells(1, 1).Resize(d.Count, 1) = Application.WorksheetFunction.Transpose(d.keys)' 以行写入
Cells(1, 2).Resize(1, d.Count) = d.keys

把字典的key或值item以行或者一列写入到单元格，如果列写入需要transpose转置一下
我们在本地窗口看下变量情况，字典有四个键值对
在这里插入图片描述

d.Remove "王五" ' 删除key-王五
删除"王五"这个键值对

在这里插入图片描述

d.RemoveAll
删除所有key`清空字典所有键值对，d为空字典对象

在这里插入图片描述

Set d = Nothing

删除字典对象，对象d的类型为Nothing的Object，不再是Dictionary
在这里插入图片描述

案例

去重

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)

求和

Sub dic_sumif()
Application.ScreenUpdating = False
Dim dic As Object
Dim arr
Dim i As ByteSet dic = CreateObject("scripting.dictionary")
With ActiveSheetarr = .UsedRangeFor 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

效果如下图：
在这里插入图片描述

计数

如果对上面水果种类进行计数：countifs，只需要将分类汇总的值改为数值1即可，每出现一次‘+1’

dic(arr(i, 1)) = dic(arr(i, 1)) + 1'在上面代码中添加下这条，修改下表头
range("f1").value2 = "计数"

效果如下图：
在这里插入图片描述

匹配

这个应该是使用字典应用最多的了，需要注意的是，如果使用单元格写入到字典，单元格同时也包含格式等信息，如果只需要单元格的值，要使用单元格.value2方法，同时，字典的值也可以是数组。
数据源：
目标：匹配‘李白’和‘后羿’的身高和体重
代码如下：

Sub data_match()
Application.ScreenUpdating = False
Dim dic As Object
Dim arr
Dim i As ByteSet dic = CreateObject("scripting.dictionary")
With ActiveSheetarr = .Cells(1, 1).CurrentRegionFor i = 2 To UBound(arr)'这里字典的值，用的是array数组，方便我们一下匹配多个数据，省去再创建字典对象麻烦。dic(arr(i, 1)) = Array(arr(i, 2), arr(i, 3))NextFor 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

效果如下：
我在这里加入了‘妲己’，遍历用字典去匹配了，但是字典并没有‘妲己’这个key，匹配出来是空，并没有报错，大家不用担心字典没有对应key匹配而出错这种情况，这样只会将结果输出为空。~
如果需要匹配的姓名后面有之前填写的身高和体重信息，但是载入字典的数据源并没有这个人的信息，我们在遍历匹配时，又不想使身高和体重被替换为空，这时候可以结合dic.exisst语句，判断姓名是否存在于字典的keys中，再输出匹配结果。
在这里插入图片描述

字典的value可以数值，字符串，数组等对象；

Array可以通过索引获取对应的值，第一个数值的索引是0；Array(1,2,3,5)(0)返回的是1

key的组合和分割

解决多字段匹配问题

dim arr
dim i,row as long
dim d as object
dim keyset d = createobject("scripting.dictionary")
with thisworkbookarr = .sheets(1).usedrangefor i = 2 to ubound(arr)d(join(array(arr(i,1),arr(i,2),arr(i,3)),"|")) = arr(i,4)next' 把字典键值对写入到工作表with .sheets("输出")row = 2for each key in d.keys.cells(row,4).value = d(key).cells(row,1).resize(1,3) = split(key,"|")row = row + 1nextend with
end with

join方法可以将数组元素按照分隔符拼接起来，返回一个字符串；
split方法，是join的反函数，将一个字符串按照分隔符分割，返回一个数组；

字典value多字段累加

比如分别加总活跃、付费等指标

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 = "" ThenMsgBox "未找到命名包含‘细分品类’文字数据源，请先下载数据源......"Application.ScreenUpdating = TrueEnd    ' 结束程序
End IfSet 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 ThenIf arr(i, 3) = "类型1" Then arr(i, 3) = "类型2"		'将类型1合并为类型2If d.exists(arr(i, 1) & "|" & arr(i, 3)) Then' vba没法直接对数组运算，将value拆开相加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)   ' 付费uv累加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 IfEnd If
Next
'On Error GoTo 0
wb.Close False    ' 关闭工作簿，不保存
Set wb = NothingWith ThisWorkbook.Sheets("表名")arr = .UsedRangeFor 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).Value2d.Remove arr(i, 1) & "|" & arr(i, 2)End IfNextlast_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).Value2last_row = last_row + 1Next
End WithApplication.ScreenUpdating = True
End Sub

字典求和和计数同时进行

有了加总与计数，也可以求平均值：sum/count

Sub test()
Dim d As Object
Dim key_cnt As Long
Dim key As StringDet d = CreateObject("scripting.dictionary")
arr = ActiveSheet.UsedRange
For i = 2 To UBound(arr)key = Join(Array(arr(i, 2), arr(i, 3)), "|")'如果字典该条键存在，累加If d.exists(key) Thenkey_cnt = d(key)(0) + 1    '天数，计数+1val_sum = d(key)(1) + arr(i, 4)      '指标值加总d(key) = Array(key_cnt, val_sum)Else'如果不存在，计数计算为1d(key) = Array(1, arr(i, 4))End If
Next
' 求平均数
for k in d.keys' 键 = array(计数，求和，平均数）d(k) = array(d(k)(0),d(k)(1),d(k)(1) / d(k)(0)   ' 数组的第一个元素下标是0
nextEnd Sub

类似sql的join操作

有点像hive里面的mapjoin逻辑
示例：游戏名称join关联游戏类型
在这里插入图片描述

Sub filter()
Application.ScreenUpdating = False' 使用筛选过滤
Dim arr
Dim brr()
Dim d As Object
Dim i As Byte
Dim row As ByteSet d = CreateObject("scripting.dictionary")
With ActiveSheet' 把游戏品类写入到字典arr = .Range("f2:g4")For i = 1 To UBound(arr)d(arr(i, 1)) = arr(i, 2)Next' 筛选头部游戏数据arr = .Range("a2:c11")row = 0ReDim brr(1 To 4, 1 To 1)For i = 1 To UBound(arr)If d.exists(arr(i, 1)) Then     ' 如果是精品游戏，则返回这一行记录row = row + 1ReDim Preserve brr(1 To 4, 1 To row)brr(1, row) = arr(i, 1)brr(2, row) = arr(i, 2)brr(3, row) = arr(i, 3)brr(4, row) = d(arr(i, 1)) ' 匹配游戏品类End IfNext' 输出.Range("j1:m1").Copy .Range("j10").Range("j11").Resize(UBound(brr, 2), 4) = Application.WorksheetFunction.Transpose(brr)
End WithApplication.ScreenUpdating = True  ' 恢复复屏幕刷新
End Sub