VBA常用小代码306：查询合并符合条件的多个结果

充满鲜花的世界到底在哪里，如果它真的存在我一定会去……

诸君好，我们今天分享的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：批量改变单元格部分字符格式。该函数的主要作用是判断一个字符在一个字符串中首次出现的位置，也就可以判断某个字符在指定字符串中是否存在，搭配间隔符后，即可精确判断重复项的问题。