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
Monday, 2 December 2024
test how to send excel range
Subscribe to:
Posts (Atom)