充满鲜花的世界到底在哪里,如果它真的存在我一定会去……
诸君好,我们今天分享的VBA小代码主题是查询并合并符合条件的多个结果~
照例举个例子,如下图所示,根据A:B列的数据,查询D列人名的特长。如果有多个特长则合并到一个单元格内,并去除重复项。
例如“看见星光”,特长有打架、打架、搬砖……,去重复后,最后的计算结果为:打架/搬砖。
代码如下:
Sub DicFinds()
Dim d As Object, Arr, Brr, i&, Kstr, 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:f' & Cells(Rows.Count, 4).End(xlUp).Row)
'查询区域装入数组brr
For i = 2 To UBound(Brr)
'遍历brr
s = Brr(i, 1)
If d.exists(s) Then
Kstr = d(s) '字典key值对应的条目字符串
Brr(i, 2) = Mid(Kstr, 2, Len(Kstr) - 2)
'使用MID LEN函数提取去除首尾'\'后的字符串
Else
Brr(i, 2) = '' '否则查询结果为空
End If
Next
With Range('d1:f' & 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:批量改变单元格部分字符格式。该函数的主要作用是判断一个字符在一个字符串中首次出现的位置,也就可以判断某个字符在指定字符串中是否存在,搭配间隔符后,即可精确判断重复项的问题。
联系客服