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