如何实现按唯一邮箱地址发送单份邮件？VBA代码优化需求

原代码遍历表格每一行时，同一邮箱对应的多行数据会重复触发邮件发送逻辑。要实现每人仅发送一封邮件，核心是记录已处理的邮箱地址，跳过重复项。以下是优化后的实现方案：

优化思路 #

• 使用Collection对象存储已发送过的邮箱，每次处理前检查是否已存在
• 修正原代码中AutoFilter的参数错误（重复定义Field参数）
• 仅对未处理过的邮箱执行邮件生成与发送逻辑

修改后的完整代码 #

Sub Emails()
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    'Setting parameters
    Dim EApp As Object
    Set EApp = CreateObject("Outlook.Application")
    Dim EItem As Object
    
    Dim I As Long
    Dim Rec As String
    Dim currentMail As String
    '新增：存储已发送邮箱的集合，利用Key唯一性去重
    Dim sentMails As New Collection
    
    Dim MListSheet As Worksheet
    Dim MListTable As ListObject
    Set MListSheet = ThisWorkbook.Sheets("DATA")
    Set MListTable = MListSheet.ListObjects("Table1")
    
    'Setting Agent for signature purposes
    Dim Agent$
    Agent = InputBox("Insert your name and surname")
    
    'Generating body of the e-mail
    For I = 2 To MListTable.ListRows.Count + 1
        Rec = MListTable.Range(I, MListTable.ListColumns("Manager").Index)
        currentMail = MListTable.Range(I, MListTable.ListColumns("Mail").Index)
        
        '检查当前邮箱是否已发送过，重复则跳过
        On Error Resume Next
        sentMails.Add currentMail, Key:=UCase(currentMail)
        On Error GoTo 0
        '添加失败（键已存在），直接进入下一行循环
        If Err.Number = 457 Then
            Err.Clear
            GoTo NextRow
        End If
        
        '修正原代码Filter的参数错误：移除重复的Field:=1
        MListTable.Range.AutoFilter Field:=MListTable.ListColumns("Manager").Index, Criteria1:=Rec
    
        If MListTable.Range.SpecialCells(xlCellTypeLastCell).Row > 1 Then
            Set EItem = EApp.CreateItem(0)
            With EItem
                .To = currentMail
                .CC = ""
                .Subject = "XXXX" & " " & Format(Now(), "mm/yyyy")
                .HTMLBody = "XXXX" _
                & "<br><br>" & "XXXX" _
                & RangetoHTML(MListTable.Range.SpecialCells(xlCellTypeVisible)) _
                & "<br>" & "BR," _
                & "<br>" & Agent
                .Display
            End With
        End If
        MListTable.AutoFilter.ShowAllData
        
NextRow:
    Next I
        
    Set EApp = Nothing
    Set EItem = Nothing
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

关键优化点说明 #

1. 重复邮箱检测：借助Collection的Key属性唯一性，尝试将邮箱添加到集合中，若触发457错误（键已存在）则跳过当前行，避免重复发送。
2. 修正语法错误：原代码中AutoFilter重复定义了Field参数，优化后移除多余的Field:=1，确保筛选逻辑正常运行。
3. 代码效率提升：将当前邮箱地址存入currentMail变量，避免多次重复读取表格，同时提升代码可读性。

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