Excel VBA宏向范圍內的唯一用戶發送電子郵件

Question

我正在嘗試創建一個 VBA 宏，它將查看 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

你可以用不同的方式來做到這一點，但我只是給你一個快速的答案來解決你的問題。 我使用 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 2

我使用了評論中提到的答案中的代碼並對其進行了修改。 創建一個類並將其命名為 AppInfo。 在這里你可以找到如何做到這一點

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 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

您可以根據需要進行修改。