Sub SendEmailsToAllUniqueIDs() Dim OutlookApp As Object Dim MailItem As Object Dim ws As Worksheet Dim emailDict As Object Dim cell As Range Dim lastRow As Long Dim email As String, data As String Dim consolidatedData As String
' Set the worksheet
Set ws = ThisWorkbook.Sheets("Sheet1") ' Adjust sheet name if needed
' Get the last row in the Email ID column (column F in this example)
lastRow = ws.Cells(ws.Rows.Count, 6).End(xlUp).Row ' Assuming "Email ID" is in column F
' Create a dictionary to consolidate data by Email ID
Set emailDict = CreateObject("Scripting.Dictionary")
' Loop through the rows to consolidate data by email
For Each cell In ws.Range("F2:F" & lastRow) ' Assuming headers are in row 1
email = cell.Value
data = "Vendor: " & cell.Offset(0, -5).Value & ", Invoice: " & cell.Offset(0, -4).Value & _
", Amount: " & cell.Offset(0, -2).Value & ", Tenor: " & cell.Offset(0, -1).Value
If emailDict.exists(email) Then
emailDict(email) = emailDict(email) & vbCrLf & data
Else
emailDict.Add email, data
End If
Next cell
' Initialize Outlook
On Error Resume Next
Set OutlookApp = GetObject(, "Outlook.Application")
If OutlookApp Is Nothing Then
Set OutlookApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
' Loop through the dictionary and send emails
For Each email In emailDict.keys
' Create a new email
Set MailItem = OutlookApp.CreateItem(0)
With MailItem
.To = email
.Subject = "Consolidated Invoice Information"
.Body = "Hello," & vbCrLf & vbCrLf & _
"Here is your consolidated invoice information:" & vbCrLf & _
emailDict(email) & vbCrLf & vbCrLf & _
"Best regards," & vbCrLf & "Your Name"
.Send ' Use .Display instead of .Send to preview the email
End With
Next email
' Cleanup
MsgBox "Emails sent successfully!"
Set MailItem = Nothing
Set OutlookApp = Nothing
Set emailDict = Nothing
End Sub