诸君好，我们今天分享的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，点击下方【阅读原文】可以下载示例文件。
温暖的拥抱，夜安，好梦。
|
|
转播
