excel轻松实现一对多

三步完成一对多

1. 替换模板，更换数据
2. 加载vba
3. 执行程序

案例介绍：
VBA轻松实现vlookup实现不了的一对多
● 背景：一共2个sheet，a和b，a表里有2列，每个金额对应的人名；b表里有一列，金额；
● 要求：要找出b表里的金额在a表里对应的人名，可能会有重复值，一个金额对应多个人名。结果需要显示在b表的第二列，如果存在一个金额有多个人名的情况，那就往右放。

Sub FindMatchingNames()
Dim wsA As Worksheet
Dim wsB As Worksheet
Dim rngA As Range
Dim rngB As Range
Dim cellB As Range
Dim names As String
Dim resultColumn As Long
' 设置工作表和范围
Set wsA = ThisWorkbook.Sheets("a") ' 修改为实际的工作表名称
Set wsB = ThisWorkbook.Sheets("b") ' 修改为实际的工作表名称
Set rngA = wsA.Range("A1:B" & wsA.Cells(wsA.Rows.Count, 1).End(xlUp).Row) ' 修改为实际的数据范围
Set rngB = wsB.Range("A1:A" & wsB.Cells(wsB.Rows.Count, 1).End(xlUp).Row) ' 修改为实际的数据范围

' 设置结果放置的起始列
resultColumn = 2 ' 结果放在 B 列的右侧

' 循环遍历 B 表中的金额
For Each cellB In rngB
    names = ""
    
    ' 在 A 表中查找匹配的人名
    For Each cellA In rngA
        If cellA.Value = cellB.Value Then
            ' 找到匹配的金额，将人名添加到 names 变量中
            names = names & cellA.Offset(0, 1).Value & ", "
        End If
    Next cellA
    
    ' 去除最后的逗号和空格
    names = Left(names, Len(names) - 2)
    
    ' 将结果写入 B 表的相应位置
    wsB.Cells(cellB.Row, resultColumn).Value = names
Next cellB
End Sub

1.2 去除b列中’多‘的重复值

' 
Sub SplitAndRemoveDuplicates()
Dim wsB As Worksheet
Dim rngB As Range
Dim lastRow As Long
Dim splitValues As Variant
Dim uniqueValues As Collection
Dim cell As Range
Dim i As Long
 '  设置工作表和范围
Set wsB = ThisWorkbook.Sheets("b") ' 修改为实际的工作表名称
Set rngB = wsB.Range("B1:B" & wsB.Cells(wsB.Rows.Count, 2).End(xlUp).Row) ' 修改为实际的数据范围

' 获取 "b" 表中最后一行的行号
lastRow = rngB.Rows.Count

' 循环遍历 "b" 表中的每个单元格
For Each cell In rngB
    ' 检查单元格是否包含逗号
    If InStr(1, cell.Value, ",") > 0 Then
        ' 使用逗号分隔单元格的值
        splitValues = Split(cell.Value, ",")
        ' 创建集合对象用于存储唯一值
        Set uniqueValues = New Collection
        On Error Resume Next
        ' 将分隔后的值添加到集合中（自动去重）
        For i = LBound(splitValues) To UBound(splitValues)
            uniqueValues.Add splitValues(i), CStr(splitValues(i))
        Next i
        On Error GoTo 0
        ' 将唯一值拼接为逗号分隔的字符串
        cell.Value = Join(CollectionToArray(uniqueValues), ",")
    End If
Next cell
End Sub
Function CollectionToArray(ByVal col As Collection) As Variant
Dim arr() As Variant
ReDim arr(1 To col.Count)
Dim i As Long
For i = 1 To col.Count
    arr(i) = col.Item(i)
Next i
CollectionToArray = arr
End Function

1. 打开 Excel 文件，确保文件中包含名为 “b” 的工作表，并在第二列中填入相应的数据。
2. 打开 Visual Basic for Applications (VBA) 编辑器（使用快捷键 Alt + F11）。
3. 在 VBA 编辑器中，插入一个新的模块（在菜单栏选择 Insert > Module）。
4. 将上述 VBA 代码复制粘贴到新模块中。
5. 修改代码中的工作表名称和数据范围，确保它们与你的实际情况相匹配。
6. 运行宏（使用快捷键 Alt + F8，然后选择 SplitAndRemoveDuplicates）。