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

Question

如果有人能帮助我避免发疯，我妈妈会很感激的。

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

例如

Column One (Email Address)  |  Column 2 (Audit Location)
Yoda1@lightside.org   |  Coruscant
Yoda1@lightside.org   |  Death Star
Yoda1@lightside.org   |  Tatooine
Vader@Darkside.org    |  Death Star
Vader@Darkside.org    |  Coruscant
Jarjar@terrible.org   |  Yavin

到目前为止，我已经创建了一个 CommandButton Controlled vba，它采用第一列并使其在新工作表中独一无二。

然后我有另一个 sub 为每个唯一的电子邮件地址创建一个电子邮件。但我坚持“如果……那么”的说法。本质上，如果电子邮件的收件人是第一列中的电子邮件地址，我想在第 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 = 电子邮件地址的第一个匹配项连同其对应的item dictEmailData(varKey) = 电子邮件正文添加到字典dictEmailData。在下一次出现电子邮件地址时，附加到电子邮件正文。建立字典后，遍历它并发送电子邮件

打印到即时窗口产生：