诸君好，我们今天分享的VBA小代码主题是使用字典查询并合并符合条件的多个结果~
照例举个例子，如下图所示，根据A:B列的数据，查询D列人名的特长。如果有多个特长则合并到一个单元格内，并去除重复项。
例如“看见星光”，特长有打架、打架、搬砖……，去重复后，最后的计算结果为：打架/搬砖。
代码如下：
Sub DicFinds()
Dim d As Object, arr, brr, i&, strKey, s$
Set d = CreateObject("scripting.dictionary")
'后期字典
arr = Range("a1:b" & Cells(Rows.Count, 1).End(xlUp).Row)
'数据源装入数组Arr
For i = 1 To UBound(arr)
s = arr(i, 1)
If Not d.exists(s) Then
'如果字典不存在关键词s那么……
d(s) = "/" & arr(i, 2) & "/"
'姓名作为key,特长作为条目
'"/"的作用除了间隔符外，也为了避免在张三丰中查询到张三的存在，误认为重复。
ElseIf InStr(1, d(s), "/" & arr(i, 2) & "/", vbTextCompare) = 0 Then
'如果字典存在关键词s那么……
'用instr函数判断字典键值s的条目中是否已存在相关特长，如果不存在，和字典原有条目合并后装入字典……
d(s) = d(s) & arr(i, 2) & "/"
End If
Next
brr = Range("d1:e" & Cells(Rows.Count, 4).End(xlUp).Row)
'查询区域装入数组brr
For i = 2 To UBound(brr)
'遍历brr
s = brr(i, 1)
If d.exists(s) Then
strKey = d(s)
'字典key值对应的条目字符串
brr(i, 2) = Mid(strKey, 2, Len(strKey) - 2)
'使用MID+LEN函数提取去除首尾"\"后的字符串
Else
brr(i, 2) = ""
'否则查询结果为假空
End If
Next
With Range("d1:e" & Cells(Rows.Count, 4).End(xlUp).Row)
.NumberFormat = "@"
'设置单元格文本格式，避免文本数值变形
.Value = brr
'brr数组放回单元格区域
End With
Set d = Nothing
MsgBox "查询结束。"
End Sub
小贴士：
1，代码使用了字典，把符合条件的多个结果合并为一个字符串作为item，回想下前几期的内容，可以得出以下3个字典常用的套路。
累加计数：d(s)=d(s)+1；
累加求和：d(s)=d(s)+val(arr(i,2));
合并同类项：d(s)=d(s)&arr(i,2)。
2，代码使用了instr函数判断值是否有重复。关于instr函数，前几天我们分享过了，参考：VBA常用小代码101：批量改变单元格部分字符格式。该函数的主要作用是判断一个字符在一个字符串中首次出现的位置，也就可以判断某个字符在指定字符串中是否存在，搭配间隔符后，即可精确判断重复项的问题。
3，示例文件在此：
https://pan.baidu.com/s/1hscT5QG
图文作者：看见星光
|
|
转播
