如何使用Excel VBA向范围内的唯一用户发送电子邮件？

Question

我试图查看A列，找到所有唯一的电子邮件地址，为每个地址创建一个Outlook电子邮件，并用该电子邮件地址所在的行填充该电子邮件的正文（也包括标题）。

示例数据：

+----------------+---------------------+---------+
|     Email      |     Application     | Version |
+----------------+---------------------+---------+
| [e-mail] | Microsoft_Office_13 | v2.0    |
| [e-mail] | Putty               | v3.0    |
| [e-mail] | Notepad             | v5.6    |
| [e-mail] | Microsoft_Office_13 | v2.0    |
| [e-mail] | Putty               | v3.0    |
| [e-mail] | Adobe_Reader        | v6.4    |
| [e-mail] | Microsoft_Office_13 | v3.6    |
| [e-mail] | Paint               | v6.4    |
| [e-mail] | Adobe_Reader        | v6.4    |
+----------------+---------------------+---------+

这是我发现的，但它会为每次列出地址创建一封电子邮件。它也没有任何代码来说明如何将一个单元格范围拉到主体中。

Sub Test1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim cell As Range

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")

    On Error GoTo cleanup
    For Each cell In Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" And _
           LCase(Cells(cell.Row, "C").Value) = "yes" Then

            Set OutMail = OutApp.CreateItem(0)
            On Error Resume Next
            With OutMail
                .To = cell.Value
                .Subject = "Reminder"
                .Body = "Hi, please find your account permissions below:"
                .Display
            End With
            On Error GoTo 0
            Set OutMail = Nothing
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

+----------------+---------------------+---------+
|     Email      |     Application     | Version |
+----------------+---------------------+---------+
| [e-mail] | Microsoft_Office_13 | v2.0    |
| [e-mail] | Putty               | v3.0    |
| [e-mail] | Adobe_Reader        | v6.4    |
+----------------+---------------------+---------+

Answer 1

你可以用不同的方法做到这一点，但我只是给你一个快速的答案，这将解决你的问题。我使用Ron de Bruin开发的函数将范围转换为html主体。

>

我删除了一个条件来检查A列中单元格的内容，所以请确保将其放回并用自己的数据进行测试

我使用字典来存储我们生成的outlook实例的电子邮件，所以如果在其他单元格中有相同的电子邮件，您将不会再次生成电子邮件

Option Explicit


Sub Test1()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim dict As Object 'keep the unique list of emails
    Dim cell As Range
    Dim cell2 As Range
    Dim rng As Range
    Dim i As Long
    Dim WS As Worksheet

    Application.ScreenUpdating = False
    Set OutApp = CreateObject("Outlook.Application")
    Set dict = CreateObject("scripting.dictionary")
    Set WS = ThisWorkbook.Sheets("Sheet1") 'change the name of the sheet accordingly

    On Error GoTo cleanup
    For Each cell In WS.Columns("A").Cells.SpecialCells(xlCellTypeConstants)
        If cell.Value Like "?*@?*.?*" Then

            'check if this email address has been used to generate an outlook email or not
            If dict.exists(cell.Value) = False Then

                dict.Add cell.Value, "" 'add the new email address
                Set OutMail = OutApp.CreateItem(0)
                Set rng = WS.UsedRange.Rows(1)

                'find all of the rows with the same email and add it to the range
                For Each cell2 In WS.UsedRange.Columns(1).Cells
                    If cell2.Value = cell.Value Then
                        Set rng = Application.Union(rng, WS.UsedRange.Rows(cell2.Row))
                    End If
                Next cell2

                On Error Resume Next
                With OutMail
                    .To = cell.Value
                    .Subject = "Reminder"
                    .HTMLBody = "Hi, please find your account permissions below:" & vbNewLine & vbNewLine & RangetoHTML(rng)
                    .Display
                End With

                On Error GoTo 0
                Set OutMail = Nothing
            End If
        End If
    Next cell

cleanup:
    Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(rng As Range)
' coded by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function