Невозможный почтовый цикл 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

Итак, я создал vba, управляемый CommandButton, который принимает первый столбец и делает его уникальным на новом листе.

Затем у меня есть другой подпрограмма, котораясоздает электронную почту для каждого уникального адреса электронной почты. Но я застрял в заявлении «Если ... Тогда». По сути, я хочу добавить информацию в столбце 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 = адрес электронной почты в словарь dictEmailData вместе с соответствующими item dictEmailData(varKey)= Тело электронной почты. При следующем появлении адреса электронной почты добавьте текст сообщения. После того как словарь создан, выполните цикл по нему и отправьте электронные письма

Печать в ближайшее окно: