不可能的Excel-VBA电子邮件循环

Question

[如果有人可以帮助我摆脱疯狂，我妈妈将不胜感激。

我有一长串电子邮件地址（很多重复）以及相关的审核位置。基本上，我需要为每个电子邮件地址创建one电子邮件，并用所有关联的审核位置的列表填充所述电子邮件正文。

例如

Column One (Email Address)  |  Column 2 (Audit Location)
[email protected]   |  Coruscant
[email protected]   |  Death Star
[email protected]   |  Tatooine
[email protected]    |  Death Star
[email protected]    |  Coruscant
[email protected]   |  Yavin

到目前为止，我已经创建了一个CommandButton Controlled vba，它接受第一列并使它在新工作表中唯一。

然后，我还有另一个子程序，它为每个唯一的电子邮件地址创建一个电子邮件。但是我被困在“ If ... Then”声明中。本质上，如果电子邮件的收件人是第一列中的电子邮件地址，我想在第2列（审核位置）中添加信息，然后继续附加到电子邮件正文中，直到电子邮件地址不再等于收件人电子邮件地址为止。任何指导都是巨大的。

   Private Sub CommandButton1_Click()

Call MakeUnique
Call EmailOut
End Sub
Sub MakeUnique()
Dim vaData As Variant
    Dim colUnique As Collection
    Dim aOutput() As Variant
    Dim i As Long

    'Put the data in an array
    vaData = Sheet1.Range("A:A").Value

    'Create a new collection
    Set colUnique = New Collection

    'Loop through the data
    For i = LBound(vaData, 1) To UBound(vaData, 1)
        'Collections can't have duplicate keys, so try to
        'add each item to the collection ignoring errors.
        'Only unique items will be added
        On Error Resume Next
            colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
        On Error GoTo 0
    Next i

    'size an array to write out to the sheet
    ReDim aOutput(1 To colUnique.Count, 1 To 1)

    'Loop through the collection and fill the output array
    For i = 1 To colUnique.Count
        aOutput(i, 1) = colUnique.Item(i)
    Next i

    'Write the unique values to column B
    Sheets.Add.Name = "Unique"
    ActiveSheet.Range("A1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput

End Sub

Sub EmailOut()
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xMailBody As String
    On Error Resume Next


    Dim cell As Range

    For Each cell In Worksheets("Unique").Columns("a").Cells.SpecialCells(xlCellTypeConstants)
    recip = cell.Value

    Set xOutApp = CreateObject("Outlook.Application")
    Set xOutMail = xOutApp.CreateItem(0)

        For Each org In Columns("b").Cells.SpecialCells(xlCellTypeConstants)
         If org.Value Like recip Then
      xMailBody = "Body content" & vbNewLine & vbNewLine & _
              "This is line 1" & " " & cell.Offset(0, 3).Value & vbNewLine & _
              [B5] & vbNewLine & _
              "This is line 2"

             End If
             Next org

On Error Resume Next
    With xOutMail
        .To = recip
        .CC = ""
        .BCC = ""
        .Subject = cell.Offset(0, 2).Value & " " & cell.Offset(0, 3).Value & " " & "Remittance Advice"
        .Body = xMailBody
        .Display   'or use .Send
    End With
    On Error GoTo 0
    Set xOutMail = Nothing
    Set xOutApp = Nothing
Next
End Sub

Answer 1

根据您的示例，我迅速编写了以下内容：

Option Explicit

Public Sub SendEmails()

 Dim dictEmailData As Object
 Dim CurrentWorkBook As Workbook
 Dim WrkSht As Worksheet
 Dim rngToLookUp As Range
 Dim lngLastRow As Long, i As Long
 Dim arryEmailData As Variant
 Dim objOutlookApp As Object, objOutlookEmail As Object
 Dim varKey As Variant

    Application.ScreenUpdating = False

    Set CurrentWorkBook = Workbooks("SomeWBName")
    Set WrkSht = CurrentWorkBook.Worksheets("SomeWSName")
    lngLastRow = WrkSht.Cells(WrkSht.Rows.Count, "A").End(xlUp).Row   'Find last row with data
    Set rngToLookUp = WrkSht.Range("A2:B" & lngLastRow)              'set range for last row of data

    arryEmailData = rngToLookUp.Value2    'Get the email data from the sheet into an array

        Set dictEmailData = CreateObject("Scripting.Dictionary")      'set the dicitonary object

            On Error GoTo CleanFail
            For i = LBound(arryEmailData, 1) To UBound(arryEmailData, 1)

                varKey = UCase(Trim(arryEmailData(i, 1)))

                    If Not dictEmailData.Exists(varKey) Then
                        dictEmailData(varKey) = vbNewLine & vbNewLine & Trim(arryEmailData(i, 2))

                    Else
                        dictEmailData(varKey) = dictEmailData(varKey) & vbNewLine & Trim(arryEmailData(i, 2))

                    End If

                varKey = Empty

            Next i

            'for each unique key in the dicitonary
            'get the corresponding item
            'created in the loop above
            Set objOutlookApp = CreateObject("Outlook.Application") 'set the outlook object
            Dim Msg As String, MailBody As String

            For Each varKey In dictEmailData.Keys
                Msg = dictEmailData.Item(varKey)
                Set objOutlookEmail = objOutlookApp.CreateItem(0)

                    MailBody = "Dear Colleague," & Msg
                    With objOutlookEmail
                        .To = varKey
                        .Subject = "Remittance Advice"
                        .Body = MailBody
                        .Send
                    End With
                Set objOutlookEmail = Nothing
                Msg = Empty: MailBody = Empty
            Next

    MsgBox "All Emails have been sent", vbInformation

CleanExit:
    Set objOutlookApp = Nothing
    Application.ScreenUpdating = True
    Exit Sub

CleanFail:
    Resume CleanExit

End Sub

将varKey =电子邮件地址的第一个出现及其相应的dictEmailDataitem=电子邮件正文添加到字典dictEmailData(varKey)中。下次出现电子邮件地址时，请附加到电子邮件正文。构建字典后，遍历字典并发送电子邮件

打印到立即窗口将产生：