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

Question

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

示例数据：

+----------------+---------------------+---------+
|     Email      |     Application     | Version |
+----------------+---------------------+---------+
| test1@test.com | Microsoft_Office_13 | v2.0    |
| test1@test.com | Putty               | v3.0    |
| test1@test.com | Notepad             | v5.6    |
| test2@test.com | Microsoft_Office_13 | v2.0    |
| test2@test.com | Putty               | v3.0    |
| test2@test.com | Adobe_Reader        | v6.4    |
| test3@test.com | Microsoft_Office_13 | v3.6    |
| test3@test.com | Paint               | v6.4    |
| test3@test.com | 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 |
+----------------+---------------------+---------+
| test2@test.com | Microsoft_Office_13 | v2.0    |
| test2@test.com | Putty               | v3.0    |
| test2@test.com | Adobe_Reader        | v6.4    |
+----------------+---------------------+---------+

Answer 1

我使用了评论中提到的answer 中的代码并对其进行了修改。 创建一个类并将其命名为 AppInfo。 Here 你知道怎么做

Option Explicit

Public app As String
Public version As String

然后将以下代码放入一个模块中。假设数据在活动工作表中，从 A1 开始，标题为电子邮件、应用程序和版本。

Option Explicit

Sub Consolidate()

#If Early Then
    Dim emailInformation As New Scripting.Dictionary
#Else
    Dim emailInformation As Object
    Set emailInformation = CreateObject("Scripting.Dictionary")
#End If

    GetEmailInformation emailInformation
    SendInfoEmail emailInformation
End Sub


Sub GetEmailInformation(emailInformation As Object)

Dim rg As Range
Dim sngRow As Range

Dim emailAddress As String
Dim myAppInfo As AppInfo
Dim AppInfos As Collection

Set rg = Range("A1").CurrentRegion    ' Assuming the list starts in A1 and DOES NOT contain empty row
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1)    ' Cut the headings

    For Each sngRow In rg.Rows

        emailAddress = sngRow.Cells(1, 1)

        Set myAppInfo = New AppInfo
        With myAppInfo
            .app = sngRow.Cells(1, 2)
            .version = sngRow.Cells(1, 3)
        End With

        If emailInformation.Exists(emailAddress) Then
            emailInformation.item(emailAddress).Add myAppInfo
        Else
            Set AppInfos = New Collection
            AppInfos.Add myAppInfo
            emailInformation.Add emailAddress, AppInfos
        End If

    Next

End Sub
Sub SendInfoEmail(emailInformation As Object)

Dim sBody As String
Dim sBodyStart As String
Dim sBodyInfo As String
Dim sBodyEnd As String
Dim emailAdress As Variant
Dim colLines As Collection
Dim line As Variant

    sBodyStart = "Hi, please find your account permissions below:" & vbCrLf


    For Each emailAdress In emailInformation
        Set colLines = emailInformation(emailAdress)
        sBodyInfo = ""
        For Each line In colLines
            sBodyInfo = sBodyInfo & _
                         "Application: " & line.app & vbTab & "Version:" & line.version & vbCrLf
        Next
        sBodyEnd = "Best Regards" & vbCrLf & _
                   "Team"

        sBody = sBodyStart & sBodyInfo & sBodyEnd
        SendEmail emailAdress, "Permissions", sBody
    Next


End Sub

Sub SendEmail(ByVal sTo As String _
              , ByVal sSubject As String _
                , ByVal sBody As String _
                  , Optional ByRef coll As Collection)


    #If Early Then
        Dim ol As Outlook.Application
        Dim outMail As Outlook.MailItem
        Set ol = New Outlook.Application
    #Else
        Dim ol As Object
        Dim outMail As Object
        Set ol = CreateObject("Outlook.Application")
    #End If

    Set outMail = ol.CreateItem(0)

    With outMail
        .To = sTo
        .Subject = sSubject
        .Body = sBody
        If Not (coll Is Nothing) Then
            Dim item As Variant
            For Each item In coll
                .Attachments.Add item
            Next
        End If

        .Display
        '.Send
    End With

    Set outMail = Nothing

End Sub

Answer 2

您可以通过不同的方式做到这一点，但我只是给您一个快速的答案来解决您的问题。我使用了 Ron de Bruin 开发的函数将范围转换为 html 正文。

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

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

• 您需要在 Outlook 新项目中使用 html 正文而不是正文，以便您有更多选项来快速粘贴内容并设置其格式（颜色、大小、字体等）

  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
  

Answer 3

在我看来，最简单的方法是将表格格式化为 Excel 中的表格（这将启用搜索和排序）。然后你可以做类似的事情，例如

email = "test1@test.com"
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set tbl = ws.ListObjects("Table1")
tbl.Range.AutoFilter Field:=1, Criteria1:=email
Set data = tbl.DataBodyRange
If (data.Rows.Count = 0) Then Exit Sub

如果执行通过检查 (data.Rows.Count > 0)，那么您可以使用 HTML 发送邮件：

Set app = CreateObject("Outlook.Application")
Set mail = OutApp.CreateItem(0)
bodyText = "<BODY style=font-size:11pt;font-family:Calibri>" & _
            " Hi, please find your account permissions below: <br> </BODY> "
With mail
    .To = email
    .Subject = "Email title here."
    .HTMLBody = bodyText & "<p>" & RangeToHTML(data)
    .Importance = 1 ' normal
    .Display
End With

需要以下辅助函数：

Function RangeToHTML(rng As Range) As String

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.Offset(1).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=")

    tempWB.Close savechanges:=False
    Kill tempFile

    Set ts = Nothing
    Set fso = Nothing
    Set tempWB = Nothing

End Function

您可以根据需要进行修改。