Excel VBA实现姓名列转去重关联邮箱拼接单字符串问题

你的原有代码核心问题是针对不同人数硬编码分支逻辑，可扩展性极差，我们可以通过「预加载映射字典+批量拆分姓名+自动去重」的逻辑完全解决这个问题，不管单单元格内有多少人都可以兼容，也无需新增辅助列。

核心优化点 #

• 使用Dictionary字典对象实现邮箱自动去重，无需手动判断字符串是否包含指定邮箱
• 使用Split函数直接拆分单元格内的姓名，适配任意数量的人员，无需分情况写分支
• 提前把Admin表的姓名-邮箱映射预加载到字典，避免每次循环都调用工作表函数，运行效率提升明显
• 自动处理逗号+换行的分隔符，兼容你当前的单元格格式

完整优化后代码 #

Sub GetUniqueEmailList()
    Dim nameDict As Object
    Dim emailSet As Object
    Dim lastRow As Long, i As Long
    Dim ownerCol As Long, firstRow As Long
    Dim cellContent As String
    Dim nameArr As Variant, nameItem As Variant
    Dim emailResult As String
    
    ' 创建字典对象：1个存姓名-邮箱映射，1个存最终的唯一邮箱做去重
    Set nameDict = CreateObject("Scripting.Dictionary")
    Set emailSet = CreateObject("Scripting.Dictionary")
    nameDict.CompareMode = vbTextCompare ' 姓名匹配不区分大小写，不需要可以删掉
    
    ' 第一步：预加载Admin表的姓名-邮箱映射，范围可根据实际调整
    For i = 4 To 200 ' 对应你原有代码的P4:P200/Q4:Q200范围
        If Sheets("Admin").Range("P" & i).Value <> "" Then
            nameDict(Trim(Sheets("Admin").Range("P" & i).Value)) = Trim(Sheets("Admin").Range("Q" & i).Value)
        End If
    Next i
    
    ' 配置Sheet12的参数，和你原有逻辑一致
    firstRow = 5
    ownerCol = 5 ' 第5列是负责人列
    lastRow = Sheets("Admin").Range("U2").Value + 4 ' 对应你原有逻辑的Last_Cell_TWDS计算
    
    ' 第二步：遍历Sheet12的负责人列
    For i = firstRow To lastRow
        cellContent = Trim(Sheets("Sheet12").Cells(i, ownerCol).Value)
        If cellContent = "" Then GoTo nextCell ' 空单元格跳过
        
        ' 先把换行符删掉，再按逗号拆分所有姓名
        cellContent = Replace(cellContent, vbLf, "") ' Alt+Enter对应的换行符是vbLf
        nameArr = Split(cellContent, ",")
        
        ' 遍历当前单元格内的所有姓名
        For Each nameItem In nameArr
            nameItem = Trim(nameItem)
            ' 姓名在映射表中存在，且对应邮箱还没加入过结果，就加入去重字典
            If nameDict.Exists(nameItem) Then
                If Not emailSet.Exists(nameDict(nameItem)) Then
                    emailSet.Add nameDict(nameItem), ""
                End If
            End If
        Next nameItem
nextCell:
    Next i
    
    ' 第三步：把去重后的邮箱拼接成单字符串，分隔符用;
    If emailSet.Count > 0 Then
        emailResult = Join(emailSet.Keys, "; ")
    End If
    
    ' 这里可以输出结果，比如弹窗显示，或者赋值给某个单元格，按需修改
    MsgBox "唯一邮箱列表：" & vbCrLf & emailResult
    ' 比如要赋值给Sheet12的A1单元格就放开下面的注释
    ' Sheets("Sheet12").Range("A1").Value = emailResult
    
    ' 释放对象
    Set nameDict = Nothing
    Set emailSet = Nothing
End Sub

代码说明 #

• 如果你Admin表的姓名邮箱范围超过200行，只需要修改预加载映射部分的循环上限即可
• 如果后续分隔符规则变动，只需要修改Replace和Split的参数即可适配
• 字典的去重逻辑是内置实现的，不管同一个姓名出现多少次，对应的邮箱只会保留一次
• 所有Trim函数都是为了去掉姓名前后的多余空格，避免因为空格导致匹配失败，不需要可以删掉

内容的提问来源于stack exchange，提问作者Maluc