复用邮件去重发送代码时，Username与TempPassword取值异常求助

我复用了Stack Overflow上的一段代码，要实现“从表格多列取数发邮件，邮箱重复就只发一封，把对应其他单元格值都包含进去”的功能。现在能正常给两位收件人发包含B列产品详情的邮件，但Username和TempPassword总是取最后一行的数据发给两个人，想解决怎么正确拿到对应无重复邮箱的这两列数据的问题。

附表格截图：

问题出在你之前的代码里，账号密码没和对应的邮箱绑定，而是循环到最后才赋值，导致所有邮箱都拿到最后一行的账号密码。按下面的思路改就行：

• 用字典存数据：以邮箱为唯一键，每个键对应的值存这个邮箱的产品列表、Username和TempPassword。
• 遍历表格时更新字典：第一次碰到某个邮箱，就把账号密码和第一个产品存进去；之后再碰到同一个邮箱，只把新产品加到列表里，不动账号密码。
• 最后遍历字典发邮件：每个邮箱对应自己的账号密码和产品集合，不会串数据。

给你个VBA示例代码（对应原代码逻辑）：

Sub SendEmails()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim emailDict As Object
    Dim i As Long
    Dim email As String
    Dim product As String
    Dim username As String
    Dim tempPwd As String
    
    Set ws = ThisWorkbook.Sheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    Set emailDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历表格，把每个邮箱的对应数据存到字典里
    For i = 2 To lastRow ' 假设第1行是表头
        email = ws.Cells(i, "A").Value ' A列是邮箱
        product = ws.Cells(i, "B").Value ' B列是产品详情
        username = ws.Cells(i, "C").Value ' C列是Username
        tempPwd = ws.Cells(i, "D").Value ' D列是TempPassword
        
        If Not emailDict.Exists(email) Then
            ' 第一次遇到这个邮箱，初始化数据
            emailDict(email) = Array(Array(product), username, tempPwd)
        Else
            ' 邮箱已存在，只加产品进去
            Dim products() As Variant
            products = emailDict(email)(0)
            ReDim Preserve products(UBound(products) + 1)
            products(UBound(products)) = product
            emailDict(email) = Array(products, emailDict(email)(1), emailDict(email)(2))
        End If
    Next i
    
    ' 遍历字典发邮件
    Dim key As Variant
    Dim outApp As Object
    Dim outMail As Object
    Set outApp = CreateObject("Outlook.Application")
    
    For Each key In emailDict.Keys
        Set outMail = outApp.CreateItem(0)
        Dim productsList As Variant
        productsList = emailDict(key)(0)
        username = emailDict(key)(1)
        tempPwd = emailDict(key)(2)
        
        ' 拼邮件内容
        Dim body As String
        body = "您好，您的产品详情：" & vbCrLf
        For Each p In productsList
            body = body & "- " & p & vbCrLf
        Next p
        body = body & vbCrLf & "您的账号：" & username & vbCrLf & "临时密码：" & tempPwd
        
        With outMail
            .To = key
            .Subject = "您的产品与账号信息"
            .Body = body
            .Display ' 测试用Display，没问题再改成.Send
        End With
        Set outMail = Nothing
    Next key
    
    Set outApp = Nothing
    Set emailDict = Nothing
End Sub

• 字典的键用邮箱，保证每个邮箱只存一组账号密码，不会被后续行覆盖。
• 第一次存邮箱时就把账号密码固定下来，后续同一邮箱只加产品，这样每个邮箱的账号密码都是对应第一次出现的那行（你也可以根据需求调整取哪一行的账号密码，逻辑统一就行）。
• 发邮件时直接从字典里取对应的数据，肯定不会串。

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