创建字典对象
'后期绑定:方便代码在其他电脑上运行,推荐。
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 = False
Dim d As Object
Set 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("张三") Then
Debug.Print "4.如果字点存在‘张三’的键,打印张三的身高:" & d("张三")
End If
d.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.keys
d.Remove "王五" ' 删除key-王五
d.RemoveAll ' 删除所有key
Set d = Nothing
Application.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("张三") Then
Debug.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 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
效果如下图:
计数
如果对上面水果种类进行计数: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 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
效果如下:
我在这里加入了‘妲己’,遍历用字典去匹配了,但是字典并没有‘妲己’这个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 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
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 = "" 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
' 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 If
End If
Next
'On Error GoTo 0
wb.Close False ' 关闭工作簿,不保存
Set wb = Nothing
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
字典求和和计数同时进行
有了加总与计数,也可以求平均值:sum/count
Sub test()
Dim d As Object
Dim key_cnt As Long
Dim key As String
Det 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) Then
key_cnt = d(key)(0) + 1 '天数,计数+1
val_sum = d(key)(1) + arr(i, 4) '指标值加总
d(key) = Array(key_cnt, val_sum)
Else
'如果不存在,计数计算为1
d(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
next
End 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 Byte
Set 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 = 0
ReDim brr(1 To 4, 1 To 1)
For i = 1 To UBound(arr)
If d.exists(arr(i, 1)) Then ' 如果是精品游戏,则返回这一行记录
row = row + 1
ReDim 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 If
Next
' 输出
.Range("j1:m1").Copy .Range("j10")
.Range("j11").Resize(UBound(brr, 2), 4) = Application.WorksheetFunction.Transpose(brr)
End With
Application.ScreenUpdating = True ' 恢复复屏幕刷新
End Sub
今天的文章vba 字典详解_VBA数组与字典解决方案分享到此就结束了,感谢您的阅读。
版权声明:本文内容由互联网用户自发贡献,该文观点仅代表作者本人。本站仅提供信息存储空间服务,不拥有所有权,不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容, 请发送邮件至 举报,一经查实,本站将立刻删除。
如需转载请保留出处:https://bianchenghao.cn/71828.html