1、字典直接创建
Dim dic as object
Set dic = Createobject("scripting.dictionary")
2、引用法
工具-引用-浏览-scrrun.dll-确定
microsoft scripting runtime 打勾
注：两者在使用上经常用创建多一点；并无太大区别。用创建的字典装入数据后并不能直接用dic.keys(N)/dic.items(N) 的格式来引用字典元素.字典元素从 dic.keys(0)开始
3、字典常用的属性与方法
方法：
.add '创建新的元素
.keys '字典的元素
.items '元素对应的值
.exists '是否存在
.remove '清除提定元素
.removeall '清除所有元素
属性:
.key
.item
.count '统计元素个数
.comparemode'值为1/0/2 文本/英文/数据库格式 '文本格式下不区分大小写
4、基础用法概念文章来源：https://www.toymoban.com/news/detail-443200.html
Sub dic1()
'Dim d As New dictionary '需工具-引用-microsoft scripting runtime选取后
Dim d As Object
Dim arr()
Dim x%
Dim m
Set d = CreateObject("scripting.dictionary")
d.CompareMode = 1 '设置为不区分大小写
[A1:A3] = Application.WorksheetFunction.Transpose(Array("A", "B", "C"))
[B1:B3] = Application.WorksheetFunction.Transpose(Array(1, 2, 3))
arr = Range("a1:b3")
For x = 1 To UBound(arr, 1)
d(arr(x, 1)) = arr(x, 2)
Next
'Stop
'MsgBox d.keys(2) '在本机测试需DIM new dictionary方式下方可用
[C1:E1] = d.Keys '字典keys元素
[C2:E2] = d.Items '字典一个key对应一个Item
[C3] = d.Count '字典D统计元素组个数
If d.Exists("D") Then 'Exists查看元素是否存在
MsgBox "1"
Else
'd("D") = 4 '不存在则增加
d.Add "D", 4 'd.add = d(key)=item
End If
Stop '暂停查看字典变化
d.Key("C") = "5" 'd.key属性指定元素改变key值
m = Application.Index(d.Keys, 3) '用createobject创建的字典用工作表index函数取出赋值
MsgBox m
If d.Exists("c") Then '前期装入的是"C"。如果不设置区分大小写则不存在
MsgBox "C存在"
Else
d.Remove "b" '字典按装入数据的顺序排序
End If
d.RemoveAll 'd.remove 指定keys删除或者Removeall全部
Stop '暂停查看字典变化
End Sub5、常见应用:读取数据/去重复/计算/匹配文章来源地址https://www.toymoban.com/news/detail-443200.html
Sub dic2() '提取不重复
Dim d As Object
Dim arr()
Dim x As Integer
Set d = CreateObject("scripting.dictionary")
d.CompareMode = 1 '设置不分大小写
[A1:A10] = Application.Transpose(Array("A", "B", "C", "a", "B", "C", "A", "B", "C", "D"))
[B1:B10] = Application.Transpose(Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
For x = 1 To 10
d(Cells(x, 1).Value) = Cells(x, 2).Value + d(Cells(x, 1).Value) '合并相对应累加，相当于SUMIF
'd.Add Cells(x, 1).Value, Cells(x, 2).Value '用add如遇有重复情况会报错
Next
Range("d1").Resize(d.Count) = Application.Transpose(d.Keys) '字典Keys关键字如装入重复则覆盖上一个,利用此特性可去重复,转置输出单元格
Range("e1").Resize(d.Count) = Application.Transpose(d.Items) '对应值汇总值输出
arr = d.Items
Stop
End Sub
Sub dic3() '查询匹配
Dim d As Object
Dim x%, y%
Dim arr()
[A1:A6] = Application.Transpose(Array("A", "B", "C", "a", "d", "D"))
[B1:B6] = Application.Transpose(Array(1, 2, 3, 4, 5, 6))
Set d = CreateObject("scripting.dictionary")
arr = Range("a1:b6")
For y = 1 To UBound(arr)
d(arr(y, 1)) = arr(y, 2) '把双列的数据分别装入1与2列,对应的值相互查询
d(arr(y, 2)) = arr(y, 1)
Next
Stop
MsgBox d("a") & d(1) & d("A")
End Sub
Sub dic4() '多列汇总,字典key1列对应item多列
Dim hrr(1 To 100, 1 To 3) '定义一个足够大的放汇总数组
Dim row As Integer
Dim arr(), x#, k#
Dim d As Object
Set d = CreateObject("scripting.dictionary")
[A1:C1] = Array("品名", "汇总1", "汇总2") '生成测试用数值
[A2:C2] = Array("A", "1", "5")
[A3:C3] = Array("A", "2", "6")
[A4:C4] = Array("C", "3", "7")
[A5:C5] = Array("C", "4", "8")
arr = Range("a2:c" & Range("a65536").End(xlUp).row)
For x = 1 To UBound(arr)
If d.Exists(arr(x, 1)) Then 'Exists某个元素在字典中是否存在
row = d(arr(x, 1)) '如果存在。行数等于字典中的顺序序号
hrr(row, 2) = hrr(row, 2) + arr(x, 2) '对应累加
hrr(row, 3) = hrr(row, 3) + arr(x, 3) '如果计数将累加数值改1
Else
k = k + 1 '如果不存在。记录序号
d(arr(x, 1)) = k '装入字典
hrr(k, 1) = arr(x, 1) '数组直接装入对应数值
hrr(k, 2) = arr(x, 2)
hrr(k, 3) = arr(x, 3)
End If
Next
Range("G2").Resize(k, 3) = hrr '汇总后结果输出
End Sub
Sub dic5() '交叉表样式汇总
Dim hrr(1 To 100, 1 To 4)
Dim d As Object
Dim row1&, column1&
Dim arr(), x#, k#
Set d = CreateObject("scripting.dictionary")
[A1:C1] = Array("品名", "月份", "值")
[A2:C2] = Array("A", "1月", "5")
[A3:C3] = Array("A", "2月", "6")
[A4:C4] = Array("C", "3月", "7")
[A5:C5] = Array("C", "2月", "8")
arr = Range("a2:c" & Range("a65536").End(xlUp).row)
For x = 1 To UBound(arr)
column1 = (InStr("1月2月3月", arr(x, 2)) + 1) / 2 + 1 'InStr（查找的字符串,找什么字符)返回字符所在位置排列的数字
If d.Exists(arr(x, 1)) Then
row1 = d(arr(x, 1))
hrr(row1, column1) = hrr(row1, column1) + arr(x, 3)
Else
k = k + 1 '多行多列汇总值在于确定行数装入，及怎么样区别列值
d(arr(x, 1)) = k '需注意列值是单条件还是多条件取值
hrr(k, 1) = arr(x, 1)
hrr(k, column1) = arr(x, 3)
End If
Next
Range("f1:h1") = Array("品名/月份", "1月", "2月")
Range("f2").Resize(k, 3) = hrr
End Sub
Sub dic6() '指定条件求整余
Dim d As Object
Dim x%
Dim arr()
Set d = CreateObject("Scripting.Dictionary")
For x = 1 To 10
d.Add x & IIf(Abs(x Mod 3) = 0, "@", ""), "" '循环1至10如果符合则加标识号@
Next
arr = WorksheetFunction.Transpose(Filter(d.Keys, "@")) '筛选只有标识号的值
[A1].Resize(UBound(arr), 1) = arr '筛选完之后输出单元格"3@,6@,9@"
[A:A].Replace "@", "" '替代掉标识符
Set d = Nothing '关闭字典
End Sub
Sub dic7() '指定类型分类并提取不重复
Dim str1$, str2$, str3$
Dim nRow%, d As Object
Dim Brr(), arr
Dim s(1 To 4) As Integer, i%
Set d = CreateObject("scripting.dictionary")
str1 = Join(Array("类型1A", "类型1B", "类型1C"), ",") '定义类型1，以数组形式储存
str2 = Join(Array("种类2A", "种类2B", "种类2C"), ",") '定义类型2，以数组形式储存
str3 = Join(Array("型3A", "型3B", "型3C"), ",") '定义类型3，以数组形式储存
nRow = Range("a1").End(xlDown).row
arr = Range("a1:a" & nRow) '数据源装入
ReDim Brr(1 To nRow, 1 To 4) '筛选后放置数组
For i = 2 To nRow '遍历数据源
If Not d.Exists(arr(i, 1)) Then '如果数据不存在执行
d(arr(i, 1)) = "" '放入字典
If str1 Like "*" & Left(arr(i, 1), 2) & "*" Then'类型文本1中有跟遍历值相像的话
s(1) = s(1) + 1 '记录类型1列的行累加
Brr(s(1), 1) = arr(i, 1) '赋值给1列
ElseIf str2 Like "*" & Left(arr(i, 1), 2) & "*" Then
s(2) = s(2) + 1
Brr(s(2), 2) = arr(i, 1)
ElseIf str3 Like "*" & Left(arr(i, 1), 2) & "*" Then
s(3) = s(3) + 1
Brr(s(3), 3) = arr(i, 1)
Else
s(4) = s(4) + 1 '都与123类型不类似的放入第4列
Brr(s(4), 4) = arr(i, 1) '记录4列的行累加
End If
End If
Next
[K1:N1] = Array("类型1", "种类2", "型3", "其他")
Range("k2:n" & nRow) = Brr '输出结果到单元格
End Sub到了这里，关于VBA(7)字典及常用应用的文章就介绍完了。如果您还想了解更多内容，请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章，希望大家以后多多支持TOY模板网！
