Excel VBA: Send automated dynamic emails [duplicate] - excel

Question

My table is structured as:
Vendor Consultor CLIENT Date OS Status
test#test.com Andrew NAME 1 25/12/2017 123456 Pend
test#test.com Andrew NAME 2 31/12/2017 789123 Pend
test134#test.com Joseph NAME 3 10/12/2017 654321 Pend
I need to consolidate everything that is pending for the seller "Andrew or Joseph" and send a single email with the "OS" list.
I am using the following code but unsuccessful as it opens a new email for each row of the worksheet:
Sub email()
Dim i As Long
Dim OutApp, OutMail As Object
Dim strto, strcc, strbcc, strsub, strbody As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
For i = 1 To Range("C5536").End(xlUp).Row
Set OutMail = OutApp.CreateItem(0)
strto = Cells(i, 1)
strsub = "OS - PENDING"
strbody = "Hello," & vbCrLf & vbCrLf & _
"Please, check your pending OS's" & vbCrLf & vbCrLf & _
"Detalhes:" & vbCrLf & _
"Consultor:" & Cells(i, 3) & vbCrLf & _
"Date:" & Cells(i, 4) & vbCrLf & _
"OS:" & Cells(i, 5) & vbCrLf & vbCrLf & _
"Best Regards" & vbCrLf & _
"Team"
With OutMail
.To = strto
.Subject = strsub
.Body = strbody
.Display
End With
On Error Resume Next
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Answer 1

Create a class cVendorline with the following code
Option Explicit
Private mClient As String
Private mDate As Date
Private mOS As String
Public Property Get Client() As String
Client = mClient
End Property
Public Property Let Client(ByVal bNewValue As String)
mClient = bNewValue
End Property
Public Property Get dDate() As Date
dDate = mDate
End Property
Public Property Let dDate(ByVal bNewValue As Date)
mDate = bNewValue
End Property
Public Property Get OS() As String
OS = mOS
End Property
Public Property Let OS(ByVal sNewValue As String)
mOS = sNewValue
End Property
Then put the following code into a module and run Consolidate
Option Explicit
Sub Consolidate()
#If Early Then
Dim emailInformation As New Scripting.Dictionary
#Else
Dim emailInformation As Object
Set emailInformation = CreateObject("Scripting.Dictionary")
#End If
GetEmailInformation emailInformation
SendInfoEmail emailInformation
End Sub
Sub GetEmailInformation(emailInformation As Object)
Dim rg As Range
Dim sngRow As Range
Dim emailAddress As String
Dim vendorLine As cVendorLine
Dim vendorLines As Collection
Set rg = Range("A1").CurrentRegion ' Assuming the list starts in A1 and DOES NOT contain empty row
Set rg = rg.Offset(1).Resize(rg.Rows.Count - 1) ' Cut the headings
For Each sngRow In rg.Rows
emailAddress = sngRow.Cells(1, 1)
Set vendorLine = New cVendorLine
With vendorLine
.Client = sngRow.Cells(1, 3)
.dDate = sngRow.Cells(1, 4)
.OS = sngRow.Cells(1, 5)
End With
If emailInformation.Exists(emailAddress) Then
emailInformation.item(emailAddress).Add vendorLine
Else
Set vendorLines = New Collection
vendorLines.Add vendorLine
emailInformation.Add emailAddress, vendorLines
End If
Next
End Sub
Sub SendInfoEmail(emailInformation As Object)
Dim sBody As String
Dim sBodyStart As String
Dim sBodyInfo As String
Dim sBodyEnd As String
Dim emailAdress As Variant
Dim colLines As Collection
Dim line As Variant
sBodyStart = "Hello," & vbCrLf & vbCrLf & _
"Please, check your pending OS's" & vbCrLf & vbCrLf & _
"Detalhes:" & vbCrLf
For Each emailAdress In emailInformation
Set colLines = emailInformation(emailAdress)
sBodyInfo = ""
For Each line In colLines
sBodyInfo = sBodyInfo & _
"Consultor:" & line.Client & vbCrLf & _
"Date:" & line.dDate & vbCrLf & _
"OS:" & line.OS & vbCrLf
Next
sBodyEnd = "Best Regards" & vbCrLf & _
"Team"
sBody = sBodyStart & sBodyInfo & sBodyEnd
SendEmail emailAdress, "OS - PENDING", sBody
Next
End Sub
Sub SendEmail(ByVal sTo As String _
, ByVal sSubject As String _
, ByVal sBody As String _
, Optional ByRef coll As Collection)
#If Early Then
Dim ol As Outlook.Application
Dim outMail As Outlook.MailItem
Set ol = New Outlook.Application
#Else
Dim ol As Object
Dim outMail As Object
Set ol = CreateObject("Outlook.Application")
#End If
Set outMail = ol.CreateItem(0)
With outMail
.To = sTo
.Subject = sSubject
.Body = sBody
If Not (coll Is Nothing) Then
Dim item As Variant
For Each item In coll
.Attachments.Add item
Next
End If
.Display
'.Send
End With
Set outMail = Nothing
End Sub