过滤掉重复的电子邮件主题并将过滤后的表格插入到电子邮件中

Question

我有一个电子表格。

我需要创建发送到 F 列中的地址的电子邮件，在 E 列中添加主题行，而不为 E4 和 E5 中的相同主题创建重复的电子邮件（每个唯一主题一封电子邮件），然后过滤数据以复制并粘贴电子邮件中的 A 列到 D 列，以查找具有相同主题的项目。

我在网上找到的代码会生成多封电子邮件，但会为每一行创建一封电子邮件，从而导致重复。
它还不包括过滤数据以将 A:D 列复制并粘贴到我的电子邮件中的步骤。

r

设置为 = 6，因为在我的个人电子表格中，这就是数据的开始位置。
正文的设置方式与我的文本所在位置相同。

Sub SendMultipleEmails()

    Dim OutApp As New Outlook.Application
    Dim OutMail As MailItem
    
    lr = Cells(Rows.Count, "C").End(xlUp).Row
    bodySignature = "Thank you," & vbLf & "Xxx Xxx"
    
    For r = 6 To lr
        Set OutMail = OutApp.CreateItem(olMailItem)
        
        With OutMail
            .To = Range("H" & r).Value
            .Subject = Range("E" & r).Value
            bodyHeader = Range("A2").Value
            bodyMain = Range("A3").Value
            .Body = bodyHeader & vbLf & vbLf & bodyMain & vbLf & vbLf & bodySignature
            .Display
        End With
    Next r
    
    Set OutMail = Nothing
    Set OutMail = Nothing

End Sub

Answer 1

您提出了两个问题：1）防止重复的电子邮件，2）用数据构建电子邮件正文。这个答案重点关注1）。

声明一个字符串变量来保存主题值。比较每一行，不同时发送邮件，相同时跳过。重置变量。但是，这假设行已按主题值排序。如果没有，请进行排序，否则代码会更复杂，并且可能涉及数组对象。

For r = 6 To lr
    If s <> Range("H" & r).Value Then
        '... email code ...
    End If
    s = Range("E" & r).Value
Next r

另一种方法是打开不同主题和电子邮件地址的记录集并循环。

    Const adOpenStatic = 3
    Const adLockOptimistic = 3
    Const adCmdText = &H1
    Dim cn As Object, rs As Object
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    
    cn.Open "Provider=MSDASQL.1;DSN=Excel Files;DBQ=" & ThisWorkbook.FullName & ";HDR=Yes';"

    rs.Open "SELECT DISTINCT [Subject], [Email Addresses] FROM [Sheet1$E5:F" & Cells(Rows.Count, "C").End(xlUp).row & "]", cn, adOpenStatic, adLockOptimistic, adCmdText
    Do While Not rs.EOF
        '... email code referencing recordset fields rs!Subject and rs![Email Addresses]...
        rs.MoveNext 'do not forget this
    Loop