使用宏向特定收件人发邮件时用户ID显示异常的技术问询

嗨，这个问题我太熟了！本质上是你的DGName变量没有按收件人做分组，而是在循环里一直累加所有符合条件的用户ID，导致每个收件人都拿到了全部ID。咱们一步步来解决：

问题根源 #

你原来的逻辑可能是逐行遍历Excel记录，只要发现未完成调查的行，就把用户ID加到DGName里，然后直接发邮件。但这样会导致后面的收件人收到的DGName是之前所有ID的累加值，而不是只属于自己的那些。

正确的解决思路 #

我们需要先按收件人邮箱分组，把每个邮箱对应的所有未完成调查的用户ID单独收集起来，再给每个收件人发送只包含自己关联ID的邮件。这里用VBA的Dictionary（字典）对象来分组是最方便的，它可以把邮箱作为“键”，对应的用户ID列表作为“值”，完美实现一对一的关联。

具体修改代码 #

下面是调整后的完整代码，你可以根据自己的实际列位置、工作表名称修改：

Sub SendSurveyReminders()
    ' 绑定要操作的工作表，替换成你的工作表名称
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("调查记录")
    
    ' 获取数据最后一行的行号（假设邮箱在A列）
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 创建字典对象，用来存储每个邮箱对应的未完成用户ID
    Dim mailDict As Object
    Set mailDict = CreateObject("Scripting.Dictionary")
    
    Dim iCounter As Long
    Dim mailDest As String
    Dim dgID As String
    Dim surveyStatus As String
    
    ' 第一步：遍历所有行，按邮箱分组收集用户ID
    For iCounter = 2 To lastRow ' 假设第1行是表头，从第2行开始处理数据
        mailDest = Trim(ws.Cells(iCounter, 1).Value) ' 邮箱所在列，这里是A列
        dgID = Trim(ws.Cells(iCounter, 2).Value) ' 用户ID所在列，这里是B列
        surveyStatus = Trim(ws.Cells(iCounter, 3).Value) ' 调查状态列，这里是C列
        
        ' 只处理未完成调查、且邮箱和ID不为空的记录
        If surveyStatus = "未完成" And mailDest <> "" And dgID <> "" Then
            ' 如果字典里已经有这个邮箱，就追加ID；没有就新建条目
            If mailDict.Exists(mailDest) Then
                mailDict(mailDest) = mailDict(mailDest) & ", " & dgID
            Else
                mailDict(mailDest) = dgID
            End If
        End If
    Next iCounter
    
    ' 第二步：遍历字典，给每个收件人发送专属提醒邮件
    Dim outApp As Object
    Dim outMail As Object
    Set outApp = CreateObject("Outlook.Application")
    
    Dim recipientMail As Variant
    For Each recipientMail In mailDict.Keys
        Set outMail = outApp.CreateItem(0)
        
        With outMail
            .To = recipientMail
            .Subject = "请完成关联用户的调查"
            ' 邮件正文里只显示当前收件人对应的用户ID
            .Body = "您好，以下是您关联的未完成调查的用户ID：" & vbCrLf & mailDict(recipientMail)
            ' 如果需要HTML格式的邮件，可以替换成下面这行
            '.HTMLBody = "<p>您好，以下是您关联的未完成调查的用户ID：</p><p>" & mailDict(recipientMail) & "</p>"
            .Display ' 测试时用Display预览，确认没问题后改成.Send直接发送
        End With
        
        Set outMail = Nothing
    Next recipientMail
    
    ' 清理对象
    Set outApp = Nothing
    Set mailDict = Nothing
    MsgBox "提醒邮件已准备完成！"
End Sub

关键注意事项 #

• 替换代码里的工作表名称、列号（比如邮箱在A列、用户ID在B列这些）为你实际的Excel结构
• 测试阶段用.Display代替.Send，先检查每个邮件里的用户ID是否正确
• 如果希望用户ID换行显示，可以把代码里的", "换成vbCrLf，这样每个ID单独占一行
• 确保你的Excel启用了宏，且Outlook是默认邮件客户端

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