如何移除Excel邮件列重复邮箱？现有VBA代码优化问询

问题背景 #

在Excel中维护关联项目的人员及邮箱列表，发送项目通知时，因部分人员参与多个项目导致邮箱重复记录，现有VBA发送邮件代码无法实现去重，尝试使用.RemoveDuplicates函数未成功。

原代码问题分析 #

原代码直接遍历H列可见单元格拼接邮箱字符串，无去重逻辑；.RemoveDuplicates是针对单元格区域的去重方法，无法直接作用于拼接后的字符串，因此无法实现去重需求。

解决方案：使用集合（Collection）实现去重 #

VBA的Collection集合不允许重复键值，可利用这一特性，遍历邮箱时先检查集合中是否已存在该邮箱，仅将未重复的邮箱加入集合，最后再将集合中的邮箱拼接为符合邮件格式的字符串。

修改后的完整代码 #

Sub SendEmail()
    Dim OutlookApp As Outlook.Application
    Dim MItem As Outlook.MailItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Msg As String
    ' 新增集合存储去重后的邮箱
    Dim uniqueEmails As New Collection
    Dim email As Variant

    ' 创建Outlook对象
    Set OutlookApp = New Outlook.Application

    ' 遍历H列可见单元格，收集不重复邮箱
    On Error Resume Next ' 忽略重复键的报错
    For Each cell In Columns("H").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" Then
            ' 以邮箱本身为键，重复时会触发错误被忽略
            uniqueEmails.Add cell.Value, Key:=UCase(cell.Value)
        End If
    Next
    On Error GoTo 0 ' 恢复正常错误处理

    ' 拼接集合中的邮箱为分号分隔的字符串
    For Each email In uniqueEmails
        EmailAddr = EmailAddr & ";" & email
    Next
    ' 移除开头多余的分号
    If Len(EmailAddr) > 0 Then EmailAddr = Mid(EmailAddr, 2)

    Msg = "Dear All," & vbNewLine & vbNewLine
    Subj = "Update"
    
    ' 创建邮件并显示
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = EmailAddr
        .Subject = Subj
        .Body = Msg
        .Display
    End With

    ' 释放对象，优化内存
    Set uniqueEmails = Nothing
    Set MItem = Nothing
    Set OutlookApp = Nothing
End Sub

代码说明 #

• 用uniqueEmails集合存储去重后的邮箱，利用集合键的唯一性实现去重；
• On Error Resume Next用于跳过添加重复邮箱时的报错，保证遍历正常完成；
• 拼接后移除开头多余的分号，避免邮件收件人格式错误；
• 添加对象释放代码，减少内存占用。

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