VBA代码修改需求：保留重复邮箱并单独发送邮件

嘿，刚好做过类似的需求，我来给你捋清楚要改哪几部分！原来的VBA是跳过重复邮箱，现在要改成每个重复邮箱都单独发邮件，核心就是干掉去重逻辑+确保每个邮箱都走一遍「模板替换+发送」的流程，具体来说：

原来的代码大概率用了Scripting.Dictionary或者数组来记录已经处理过的邮箱，跳过重复项，比如类似这样的代码：

Dim emailDict As Object
Set emailDict = CreateObject("Scripting.Dictionary")

' 遍历邮箱列表时的去重判断
For Each emailAddr In emailRange
    If Not emailDict.Exists(emailAddr.Value) Then
        emailDict.Add emailAddr.Value, True
        ' 这里是发送邮件的代码
    End If
Next

你要把这个去重的判断完全删掉，直接让每个邮箱都触发发送逻辑——也就是去掉If Not emailDict.Exists(...) Then和对应的End If，把发送邮件的代码直接放在循环里：

' 删掉所有字典相关的代码，直接遍历每个邮箱就发
For Each emailAddr In emailRange
    ' 这里直接放发送邮件的代码
    SendCustomEmail emailAddr.Value, templateData
Next

如果你的邮件模板是提前加载好的，一定要注意不要在循环外一次性替换完所有变量，而是要在遍历每个邮箱的时候，重新复制一份原始模板，再替换当前邮箱对应的专属信息（比如用户名、订单号），这样即使是同一个邮箱，每次发送的内容（如果有变量差异）也会正确，而且能单独发送。示例代码：

' 先把原始模板存下来（比如从Excel单元格/Word文档读取）
Dim originalTemplate As String
originalTemplate = ThisWorkbook.Sheets("模板").Range("A1").Value

' 遍历所有邮箱（包括重复的）
For Each row In dataRange.Rows
    Dim currentEmail As String
    currentEmail = row.Range("A1").Value ' 假设邮箱在A列
    
    ' 每次循环都复制原始模板，避免修改原始内容
    Dim emailContent As String
    emailContent = originalTemplate
    
    ' 替换当前行的特定信息，比如B列是用户名，C列是订单号
    emailContent = Replace(emailContent, "[用户名]", row.Range("B1").Value)
    emailContent = Replace(emailContent, "[订单号]", row.Range("C1").Value)
    
    ' 调用发送函数，给当前邮箱发邮件
    SendSingleEmail currentEmail, emailContent
Next

• 如果用Outlook发送邮件，一定要在循环内新建MailItem对象，别在循环外创建一个然后重复修改发送——否则后面的邮件会覆盖前面的内容，最后只发出去最后一封：

  ' 错误示例：循环外创建邮件对象
  Dim olMail As Outlook.MailItem
  Set olMail = Outlook.Application.CreateItem(olMailItem)
  
  ' 正确示例：循环内每次新建
  For Each emailAddr In emailRange
      Dim olMail As Outlook.MailItem
      Set olMail = Outlook.Application.CreateItem(olMailItem)
      olMail.To = emailAddr.Value
      olMail.HTMLBody = emailContent
      olMail.Send
  Next
  

• 如果重复邮箱对应的模板变量完全一样，也没关系，只要循环到就发送，就能实现同一个邮箱收到多封相同内容邮件的效果。

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