Impossible Excel-VBA Email Loop - excel

Question

If someone could help me from going insane, my mother would appreciate it.
I have a long list of email addresses (many repeats) with associated Audit Locations. Basically I need to create one email for each email address and populate said email body with a list of all the associated Audit Locations.
e.g.
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
So far I have created a CommandButton Controlled vba that takes Column One and makes it unique in a new worksheet.
Then I have another sub that creates an email for each unique email address. But I am stuck on the "If...Then" statement. Essentially, I want to add the information in Column 2 (Audit Location) if the Recipient of the email is the email address in Column One and then continue to append to the email body until the email address no longer equals the recipient email address. Any guidance would be huge.
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

Based on your example I quickly wrote the following:
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
Add the first occurrence of a varKey = email address to the dictionary dictEmailData along with its corresponding item dictEmailData(varKey) = Email body. On the next occurrence of the email address, append to the Email body. Once the dictionary is built, loop through it and send the emails
Printing to the immediate window yields: