Choose different email body based on cell value - excel

There are 3 body contents to be picked based on the value in D column.
1) if "D" column value is "High" then bodycontent1 should be selected
2) if "D" column value is "Medium" then bodycontent2 should be selected
3) if "D" column value is "Low" then bodycontent3 should be selected
The below code just picks the bodycontent1 for any criteria.
Code:
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Variant
Dim MsgFwd As MailItem
Dim Items As Outlook.Items
Dim Email As String
Dim Email1 As String
Dim ItemSubject As String
Dim lngCount As Long
Dim i As Long
Dim RecipTo As Recipient
Dim RecipCC As Recipient
Dim RecipBCC As Recipient
Dim onbehalf As Variant
Dim EmailBody As String
Dim BodyName As String
Dim Bodycontent1 As String
Dim Bodycontent2 As String
Dim Bodycontent3 As String
Dim Criteria1 As String
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
i = 2 ' i = Row 2
With Worksheets("Sheet1") ' Sheet Name
Do Until IsEmpty(.Cells(i, 1))
ItemSubject = .Cells(i, 1).Value '(i, 1) = (Row 2,Column 1)
Email = .Cells(i, 16).Value '(i, 2) = (Row 2,Column 2)
Email1 = .Cells(i, 2).Value
Criteria1 = .Cells(i, 4).Value
Bodycontent1 = "Hello this is for testing purpose1" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"
Bodycontent2 = "Hello this is for testing purpose2" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"
Bodycontent3 = "Hello this is for testing purpose3" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"
'// Loop through Inbox Items backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items.Item(lngCount)
If Item.Subject = ItemSubject Then ' if Subject found then
Set MsgFwd = Item.Forward
Set RecipTo = MsgFwd.Recipients.Add(Email1)
Set RecipTo = MsgFwd.Recipients.Add("secnww#hp.com")
Set RecipBCC = MsgFwd.Recipients.Add(Email)
MsgFwd.SentOnBehalfOfName = "doc#hp.com"
BodyName = .Cells(i, 3).Value
RecipTo.Type = olTo
RecipBCC.Type = olBCC
Debug.Print Item.Body
If Criteria1 = "high" Then
MsgFwd.HTMLBody = Bodycontent1 & Item.HTMLBody
ElseIf Criteria1 = "medium" Then
MsgFwd.HTMLBody = Bodycontent2 & Item.HTMLBody
Else 'If Criteria1 = "Low" Then
MsgFwd.HTMLBody = Bodycontent3 & Item.HTMLBody
MsgFwd.Display
End If
End If
Next ' exit loop
i = i + 1 ' = Row 2 + 1 = Row 3
Loop
End With
Set olApp = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set Item = Nothing
Set MsgFwd = Nothing
Set Items = Nothing
MsgBox "Mail sent"
End Sub

You should use Select Case rather than If/ElseIf
See the part about LastRow which is clear than Loop+i=i+1
I've added an Exit For (commented), in case you want to gain time, and only forward the 1st message with the subject you're looking for!
Final code :
Option Explicit
Public Sub Example()
Dim olApp As Outlook.Application
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Variant
Dim MsgFwd As MailItem
Dim wS As Worksheet
Dim Items As Outlook.Items
Dim Email As String
Dim Email1 As String
Dim ItemSubject As String
Dim lngCount As Long
Dim LastRow As Long
Dim i As Long
Dim BodyName As String
Dim Bodycontent1 As String
Dim Bodycontent2 As String
Dim Bodycontent3 As String
Dim Criteria1 As String
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Items = Inbox.Items
Bodycontent1 = "Hello this is for testing purpose1" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"
Bodycontent2 = "Hello this is for testing purpose2" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"
Bodycontent3 = "Hello this is for testing purpose3" & "<BR>" & _
"Regards," & "<BR>" & _
"Kelvin"
Set wS = thisworkbook.Worksheets("Sheet1") ' Sheet Name
With wS
LastRow = .Range("A" & .rows.Count).End(xlup).Row
For i = 2 To LastRow
ItemSubject = .Cells(i, 1).value
Email = .Cells(i, 16).value
Email1 = .Cells(i, 2).value
Criteria1 = .Cells(i, 4).value
BodyName = .Cells(i, 3).value
'// Loop through Inbox Items backwards
For lngCount = Items.Count To 1 Step -1
Set Item = Items.Item(lngCount)
If Item.Subject <> ItemSubject Then
Else
'If Subject found then
Set MsgFwd = Item.Forward
With MsgFwd
.To = Email1 & " ; secnww#hp.com"
.BCC = Email
.SentOnBehalfOfName = "doc#hp.com"
Select Case LCase(Criteria1)
Case Is = "high"
.HTMLBody = Bodycontent1 & Item.HTMLBody
Case Is = "medium"
.HTMLBody = Bodycontent2 & Item.HTMLBody
Case Is = "low"
.HTMLBody = Bodycontent3 & Item.HTMLBody
Case Else
MsgBox "Criteria : " & Criteria1 & " not recognised!", _
vbCritical + vbOKOnly, "Case not handled"
End Select
.Display
'Exit For
End With 'MsgFwd
End If
Next lngCount
Next i
End With 'wS
Set olApp = Nothing
Set olNs = Nothing
Set Inbox = Nothing
Set Item = Nothing
Set MsgFwd = Nothing
Set Items = Nothing
MsgBox "Mail sent"
End Sub

Related

Search Inbox by Subject, Sender and Date for each email address in Excel range

I search the inbox folder for given subject, sender from column 1 and date.
Based on the result it should populate rows in column 2 with Yes or No. But it populates all rows as No. I'm sure I should see at least one Yes.
The value of variable i is always nothing. Looks like it is a problem with filterstring variable.
Sub searchemailsreceived()
Application.ScreenUpdating = False
ThisWorkbook.Activate
Dim ol As outlook.Application
Dim ns As outlook.Namespace
Dim fol As outlook.Folder
Dim i As Object
Dim mi As outlook.MailItem
Dim filterstring As String
Dim dmi As outlook.MailItem
Dim lstRow As Long
Dim rng As Range
ThisWorkbook.Sheets("Sheet1").Activate
lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Set rng = Range("A2:A" & lstRow)
Set ol = New outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Set dmi = ol.CreateItem(olMailItem)
For Each cell In rng
filterstring = "#SQL=(""urn:schemas:httpmail:fromemail"" LIKE '%" & Range(cell.Address).Offset(0, 0).Value2 & "%' AND ""urn:schemas:httpmail:subject"" LIKE '%This is my subject%' AND ""urn:schemas:httpmail:datereceived"" >= '4/1/2021 12:00 AM')"
For Each i In fol.Items.Restrict(filterstring)
If i.Class = olMail Then
Range(cell.Address).Offset(0, 1).Value2 = "Yes"
GoTo landhere
End If
Next i
Range(cell.Address).Offset(0, 1).Value2 = "No"
landhere:
Next cell
Set mi = Nothing
Set dmi = Nothing
Set ol = Nothing
Application.ScreenUpdating = False
End Sub
Try the following cleaned function (untested):
Sub SearchEmailsReceived()
Application.ScreenUpdating = False
Dim ol As Outlook.Application: Set ol = New Outlook.Application
Dim fol As Outlook.MAPIFolder: Set fol = ol.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim lstRow As Long: lstRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range: Set rng = ws.Range("A2:A" & lstRow)
Dim i As Object, filterstring As String, Cell As Range
Dim dmi As Outlook.MailItem: Set dmi = ol.CreateItem(olMailItem)
For Each Cell In rng
filterstring = "#SQL=urn:schemas:httpmail:fromemail LIKE '%" & Cell.Value2 & "%' AND urn:schemas:httpmail:subject LIKE '%This is my subject%' AND urn:schemas:httpmail:datereceived >= '4/1/2021 12:00 AM'"
Cell.Offset(0, 1) = "No"
For Each i In fol.Items.Restrict(filterstring)
If i.Class = olMail Then Cell.Offset(0, 1) = "Yes"
Next i
Next Cell
Set dmi = Nothing
Set ol = Nothing
Application.ScreenUpdating = False
End Sub
The answer linked by #niton shows the SQL=urn... doesn't contain quote marks so they have been removed. You may want to cut down the filterstring and test whether each additional AND statement causes issues though. Maybe comment out subject and date to test whether it finds any e-mails from the recipients first then work them back in the further requirements once you know the base works ok
the fromemail schema didn't work for me. what worked for me is ""http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & Cell.Value2 & "%'
Thank you for helping.
Demonstration with "urn:schemas:httpmail:fromemail" and "proptag/0x0065001f".
Option Explicit
Sub searchemailsreceived_Demo()
'Application.ScreenUpdating = False
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim folItems As Outlook.Items
Dim folItemsSQL As Outlook.Items
Dim folItems1SQL As Outlook.Items
Dim folItems2SQL As Outlook.Items
Dim folItems3SQL As Outlook.Items
Dim i As Long
Dim filterString1 As String
Dim filterString2 As String
Dim filterString3 As String
Dim filterStringSQL As String
Dim filterString1SQL As String
Dim filterString2SQL As String
Dim filterString3SQL As String
Dim lastRowColA As Long
Dim rng As Range
Dim cell As Object
Dim foundFlag As Boolean
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
lastRowColA = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("A2:A" & lastRowColA)
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
Set folItems = fol.Items
Debug.Print "folItems.Count..: " & folItems.Count
For Each cell In rng
'filterString1 = """http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & cell.Value2 & "%'"
' or
' Based on sample data, a filter without wildcards may be preferable.
' Col A = email addresses starting in row 2
Debug.Print
filterString1 = """urn:schemas:httpmail:fromemail"" LIKE '" & cell.Value2 & "'"
Debug.Print "filterString1 ..: " & filterString1
filterString1SQL = "#SQL=(" & filterString1 & ")"
Debug.Print "filterString1SQL: " & filterString1SQL
Set folItems1SQL = folItems.Restrict(filterString1SQL)
Debug.Print "folItems1SQL.Count.: " & folItems1SQL.Count
' Condition 1
foundFlag = False
For i = 1 To folItems1SQL.Count
If folItems1SQL(i).Class = olMail Then
Debug.Print "i = " & i
Debug.Print " - folItems1SQL(i).SenderEmailAddress: " & folItems1SQL(i).SenderEmailAddress
cell.Offset(0, 2).Value2 = "Yes"
foundFlag = True
Exit For
End If
Next
If foundFlag = False Then
cell.Offset(0, 2).Value2 = "No"
End If
' Condition 2
Dim strSubject As String
strSubject = "test"
Debug.Print
filterString2 = """urn:schemas:httpmail:subject"" LIKE '%" & strSubject & "%'"
Debug.Print "filterString2 ..: " & filterString2
filterString2SQL = "#SQL=(" & filterString2 & ")"
Debug.Print "filterString2SQL: " & filterString2SQL
Set folItems2SQL = folItems.Restrict(filterString2SQL)
Debug.Print "folItems2SQL.Count.: " & folItems2SQL.Count
foundFlag = False
For i = 1 To folItems2SQL.Count
If folItems2SQL(i).Class = olMail Then
Debug.Print "i = " & i
Debug.Print " - folItems2SQL(i).Subject: " & folItems2SQL(i).Subject
cell.Offset(0, 3).Value2 = "Yes"
foundFlag = True
Exit For
End If
Next
If foundFlag = False Then
cell.Offset(0, 3).Value2 = "No"
End If
' Condition 3
Dim strDate As String
strDate = "2021/04/01 12:00 AM"
Debug.Print
filterString3 = """urn:schemas:httpmail:datereceived"" >= '" & strDate & "'"
Debug.Print "filterString3: " & filterString3
filterString3SQL = "#SQL=(" & filterString3 & ")"
Debug.Print "filterString3SQL: " & filterString3SQL
Set folItems3SQL = folItems.Restrict(filterString3SQL)
Debug.Print "folItems3SQL.Count : " & folItems3SQL.Count
foundFlag = False
For i = 1 To folItems3SQL.Count
If folItems3SQL(i).Class = olMail Then
Debug.Print "i = " & i
Debug.Print " - folItems3SQL(i).ReceivedTime: " & folItems3SQL(i).ReceivedTime
cell.Offset(0, 4).Value2 = "Yes"
foundFlag = True
Exit For
End If
Next
If foundFlag = False Then
cell.Offset(0, 4).Value2 = "No"
End If
' Condition 1 AND Condition 2 AND Condition 3
Debug.Print
Debug.Print filterString1
Debug.Print filterString2
Debug.Print filterString3
filterStringSQL = "#SQL=(" & filterString1 & " AND " & filterString2 & " AND " & filterString3 & ")"
Debug.Print "filterStringSQL: " & filterStringSQL
Set folItemsSQL = folItems.Restrict(filterStringSQL)
Debug.Print "folItemsSQL.Count : " & folItemsSQL.Count
foundFlag = False
For i = 1 To folItemsSQL.Count
If folItemsSQL(i).Class = olMail Then
Debug.Print "i = " & i
Debug.Print " - folItemsSQL(i).SenderEmailAddress: " & folItemsSQL(i).SenderEmailAddress
Debug.Print " - folItemsSQL(i).Subject...........: " & folItemsSQL(i).Subject
Debug.Print " - folItemsSQL(i).ReceivedTime......: " & folItemsSQL(i).ReceivedTime
Debug.Print
cell.Offset(0, 1).Value2 = "Yes"
foundFlag = True
Exit For
End If
Next
If foundFlag = False Then
cell.Offset(0, 1).Value2 = "No"
End If
Next cell
Application.ScreenUpdating = True
End Sub
Actually I tried a smaller and it worked but thank you.
Sub searchemailsreceived()
Application.ScreenUpdating = False
ThisWorkbook.Activate
Dim ol As Outlook.Application: Set ol = New Outlook.Application
Dim ns As Outlook.Namespace: Set ns = ol.GetNamespace("MAPI")
Dim fol As Outlook.Folder: Set fol = ns.GetDefaultFolder(olFolderInbox)
Dim filterstring As String
Dim lstRow As Long: lstRow = Cells(Rows.Count, 2).End(xlUp).Row
Dim rng As Range: Set rng = Range("A2:A" & lstRow)
ThisWorkbook.Sheets("Sheet1").Activate
For Each Cell In rng
filterstring = "#SQL=(""http://schemas.microsoft.com/mapi/proptag/0x0065001f"" CI_STARTSWITH '%" & Cell.Value2 & "%' AND ""urn:schemas:httpmail:subject"" LIKE '%This is a subject%' AND ""urn:schemas:httpmail:datereceived"" >= '1/1/2000 12:00 AM')"
Range(Cell.Address).Offset(0, 2).Value2 = fol.Items.Restrict(filterstring).Count
filterstring = ""
Next Cell
Set ol = Nothing
Application.ScreenUpdating = False
End Sub

How to resolve vba runtime error 91, when trying to close a PPT

I wrote code to send automated birthday emails using Outlook and PPT. My code was working fine for a while and was getting the result as expected. All of the sudden, I started getting error 91 and debugging tool points to the line, where the PPT closes.
myDOBPPT.Close
I have declared the PPT and assigned a destination path for my template.
Any clues or solution on why this is occurring all of a sudden?
Option Explicit
Private Sub Btn_SendEmail_Click()
'Declaring Outlook
Dim OutlookApp As Outlook.Application
Dim OutlookMail As Outlook.MailItem
'Declaring Sender Outlook
Dim SenderOutlookApp As Outlook.Application
Dim SenderOutlookMail As Outlook.MailItem
'Declaring PPT
Dim objPPT As PowerPoint.Application
Dim myDOBPPT As PowerPoint.Presentation
Dim DestinationPPT As String
'Assigning Path of files
DestinationPPT = "C:\Users\charles.hill\Desktop\BirthdayAutomation\Birthday_Automation.pptx"
'Declaring and assigning values for varibales
Dim i As Long
i = 2
Dim randomslidenumber As Integer
Dim FirstSlide As Double
Dim LastSlide As Double
Dim Mydate As Date
Mydate = Date
'Declaring the Logo Image
Dim LogoImage As String
'Assigning Path of files
LogoImage = "C:\Users\charles.hill\Pictures\Saved Pictures\TIGA Logo.jpg"
'Worksheets("Emp_Details").Range("A2:A" & Range("A2").End(xlDown).Row).ClearContents
Application.ScreenUpdating = False
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT) 'PPT with birthday images opens
If Mydate = DateSerial(Year(Date), Month(Cells(i, 4).Value), Day(Cells(i, 4).Value)) Then
'Jump to Random Slide
With myDOBPPT
FirstSlide = 1
LastSlide = myDOBPPT.Slides.Count
Randomize
randomslidenumber = Int(((LastSlide - FirstSlide) * Rnd() + FirstSlide))
End With
With myDOBPPT.Slides(randomslidenumber)
.Shapes("NameOval").TextEffect.Text = WorksheetFunction.Proper(Sheet1.Cells(i, "B").Value) 'Employee's Name
.Shapes("DOB").TextEffect.Text = VBA.Format(Sheet1.Cells(i, "D").Value, "DD Mmm") 'Employee's DOB
.Export (ActiveWorkbook.Path & "\slide") & ".gif", "gif"
End With
Set OutlookApp = New Outlook.Application
Set OutlookMail = OutlookApp.CreateItem(olMailItem)
OutlookMail.To = Cells(i, 5).Value
OutlookMail.CC = Cells(i, 6).Value
OutlookMail.BCC = ""
OutlookMail.Subject = "Happy Birthday " & Cells(i, 2).Value & "!!"
OutlookMail.Attachments.Add (ActiveWorkbook.Path & "\slide.gif")
OutlookMail.HTMLBody = "Good Morning All" & "<br> <br>" & _
"Please join TIGA in wishing " & Cells(i, 2).Value & " " & Cells(i, 3).Value & " a Happy Birthday! Hope you have a fantastic day" & "<br> <br>" & _
"<center><img src='cid:slide.gif' height='576' width='768'/></center>" & "<br> <br>" & _
"Best Wishes and Regards," & "<br>" & "HR Team" & "<br> <br>" & _
"<img src='C:\Users\charles.hill\Pictures\Saved Pictures\TIGA Logo.jpg'/>"
OutlookMail.Display
OutlookMail.Send
'Updates Email Sent column to Yes
With Worksheets("Emp_Details").Cells(i, 7)
.Value = "Yes"
End With
End If
Next i
myDOBPPT.Close
Set myDOBPPT = Nothing
objPPT.Quit
Set objPPT = Nothing
Set OutlookMail = Nothing
Set OutlookApp = Nothing
On Error Resume Next
VBA.Kill (ActiveWorkbook.Path & "\slide.gif")
ActiveWorkbook.Save
MsgBox "Processing Done", vbInformation
MsgBox "Records Updated and Workbook saved", vbInformation
'Declaring variables for updating Email sent column and send birthday wishes log.
Dim RowNum As Integer
RowNum = 2
Dim CurrentDate As Date
CurrentDate = Date
Dim Last_Row
Dim xInspect As Object
Dim PageEditor As Object
Const wdFormatPlainText = 0
'Worksheets("Sheet1").Range("G2:G500").ClearContents
'For RowNum = 2 To Cells(Rows.Count, 1).End(xlUp).Row
' If Worksheets("Sheet1").Cells(RowNum, 4).Value = CurrentDate Then
' Worksheets("Sheet1").Cells(RowNum, 7).Value = "Yes"
'End If
'Next RowNum
'ActiveWorkbook.Save
'MsgBox "Records Updated and Workbook saved", vbInformation
Set SenderOutlookApp = New Outlook.Application
Set SenderOutlookMail = SenderOutlookApp.CreateItem(olMailItem)
Set xInspect = SenderOutlookMail.GetInspector
Set PageEditor = xInspect.WordEditor
Last_Row = Worksheets("Emp_Details").Range("A" & Rows.Count).End(xlUp).Row
Worksheets("Log").Range("A2:I500").ClearContents
For RowNum = 2 To Last_Row
If Worksheets("Emp_Details").Cells(RowNum, "G").Value = "Yes" Then
Worksheets("Emp_Details").Rows(RowNum).Copy Destination:=Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Next RowNum
Worksheets("Log").UsedRange.Copy
With SenderOutlookMail
.To = "sreenandini.jayaram#tiga.us"
.CC = ""
.BCC = ""
.Subject = "Birthday Wishes Log" & " " & Date
.Body = "Birthday wishes were sent out to the following Employees" & vbCrLf
.Display
PageEditor.Application.Selection.Start = Len(.Body)
PageEditor.Application.Selection.End = PageEditor.Application.Selection.Start
PageEditor.Application.Selection.PasteAndFormat Type:=wdFormatPlainText
.Display
.Send
Set PageEditor = Nothing
Set xInspect = Nothing
End With
Set SenderOutlookMail = Nothing
Set SenderOutlookApp = Nothing
Application.ScreenUpdating = True
End Sub 'Ending Button Click Sub-routine
You are getting that error because you are initializing the object inside the loop and trying to close it outside the loop. If the code doesn't enter the loop then myDOBPPT will be Nothing
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
Next i
myDOBPPT.Close
You can also test it by changing myDOBPPT.Close to the below.
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
Next i
If myDOBPPT Is Nothing Then
MsgBox "myDOBPPT is nothing"
End If
Move it inside the loop
For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
'
'
'
Set myDOBPPT = objPPT.Presentations.Open(DestinationPPT)
'
'
'
myDOBPPT.Close
Next i

Need to send email to multiple reciepent from filter data

I wanted to send email to multiple recipient as per their fund code. for eg. in given image I want email for QR fund in column A to be sent out to B2,B3 and B4 in same email and subject line should be "C2" for next I want email for RTIO fund in column A to be sent out to B5, B7 and B8 in same email and subject line should be "C5" and so on
Sub SendMultipleEmails()
Dim Mail_Object, OutApp As Variant
With ActiveSheet
lastrow = .Cells(.Rows.Count, "b").End(xlUp).Row
End With
For i = 2 To lastrow
Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)
With OutApp
.Subject = "Your subject here"
.Body = "Your message here"
.To = Cells(i, 2).Value
.dISPLAY
End With
I am not able to apply filter condition and get multiple email recipient in one email
Try this code:
Sub SendMultipleEmailsaa()
Dim Mail_Object, OutApp As Object
Dim ws As Worksheet: Set ws = ActiveSheet
Dim arr() As Variant
LastRow = ws.Cells(ws.Rows.Count, "b").End(xlUp).row
arr = ws.Range("A2:A" & LastRow)
Set Mail_Object = CreateObject("Outlook.Application")
first = 2
For i = LBound(arr) To UBound(arr)
If i = UBound(arr) Then GoTo YO
If arr(i + 1, 1) = arr(i, 1) Then
first = WorksheetFunction.Min(first, i + 1)
Else
YO:
Set OutApp = Mail_Object.CreateItem(0)
With OutApp
.Subject = ws.Range("C" & i + 1).Value
.Body = "Your message here"
.Display
.To = ws.Range("A" & i + 1).Value
For j = first To i
.Recipients.Add ws.Range("A" & j).Value
Next
first = i + 2
End With
End If
Next
End Sub
To automatically sort add this code below the calculation on LastRow in above code:
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=ws.Range("A2:A" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange ws.UsedRange
.Header = False
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Another Update:
Dim bc As String
With OutApp
.Subject = ws.Range("C" & i + 1).Value
.Body = "Your message here"
.Display
bc = ws.Range("A" & i + 1).Value
For j = first To i
bc = bc & ";" & ws.Range("A" & j).Value
Next
.BCC = bc
first = i + 2
End With
Here is my solution:
Option Explicit
Public Sub Main()
Dim rngSource As Range: Set rngSource = ExpandRange(ThisWorkbook.Worksheets("Sheet1").Range("A2"))
ReadDataAndSendAllMail rngSource
End Sub
Public Function ExpandRange(rngTopLeftCell As Range) As Range
With rngTopLeftCell.Worksheet
Set ExpandRange = rngTopLeftCell.Resize( _
.Cells(.Rows.Count, rngTopLeftCell.Column).End(xlUp).Row - rngTopLeftCell.Row + 1, _
.Cells(rngTopLeftCell.Row, .Columns.Count).End(xlToLeft).Column - rngTopLeftCell.Column + 1)
End With
End Function
Public Sub ReadDataAndSendAllMail(rngSource As Range)
Dim dctData As Dictionary: Set dctData = ReadData(rngSource)
SendAllMail dctData
End Sub
Public Function ReadData(rngSource As Range) As Dictionary
Dim dctResult As Dictionary: Set dctResult = New Dictionary
Dim rngRecord As Range: For Each rngRecord In rngSource.Rows
Dim dctRecord As Dictionary: Set dctRecord = New Dictionary
dctRecord.Add "Fund", rngRecord.Cells(1, 1).Value
dctRecord.Add "Email", rngRecord.Cells(1, 2).Value
dctRecord.Add "Subject", rngRecord.Cells(1, 3).Value
dctRecord.Add "Attachment", rngRecord.Cells(1, 4).Value
If Not dctResult.Exists(dctRecord("Fund")) Then
dctResult.Add dctRecord("Fund"), New Collection
End If
dctResult(dctRecord("Fund")).Add dctRecord
Next rngRecord
Set ReadData = dctResult
End Function
Public Sub SendAllMail(dctData As Dictionary)
Const cstrEmailDelimiter As String = "; " ' Note: Observe which delimiter your local version of Outlook uses and replace this value with it
Dim moaOutlook As Outlook.Application: Set moaOutlook = New Outlook.Application
Dim varFund As Variant: For Each varFund In dctData.Keys
Dim strFund As String: strFund = vbNullString
Dim strTo As String: strTo = vbNullString
Dim strSubject As String: strSubject = vbNullString
Dim strBody As String: strBody = vbNullString
Dim strAttachmentPath As String: strAttachmentPath = vbNullString
Dim dctRecord As Dictionary: For Each dctRecord In dctData(varFund)
strFund = dctRecord("Fund")
strTo = strTo & cstrEmailDelimiter & dctRecord("Email")
strSubject = dctRecord("Subject")
strBody = vbNullString ' Note: Replace vbNullString with some text for the message body
strAttachmentPath = dctRecord("Attachment")
Next dctRecord
strTo = Mid(strTo, Len(cstrEmailDelimiter) + 1)
SendMail moaOutlook, strTo, strSubject, vbNullString, strAttachmentPath
Next varFund
moaOutlook.Quit
End Sub
Public Sub SendMail(moaOutlook As Outlook.Application, strTo As String, strSubject As String, strBody As String, strAttachmentPath As String)
Dim omiMailItem As Outlook.MailItem: Set omiMailItem = moaOutlook.CreateItem(olMailItem)
With omiMailItem
.To = strTo
.Subject = strSubject
.Body = strBody ' Note use .HTMLBody if you want to send an HTML email
.Attachments.Add strAttachmentPath
.display ' Note: If you want to manually press the send button, otherwise comment out this line
' .send ' Note: If you want to automatically send it, uncomment this line
End With
End Sub
I hope the function names make it easier to understand and reuse. I tested it, and worked for me.

Excel VBA: Send automated dynamic emails [duplicate]

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
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

Sending Email Based on Cell Value within a Loop

I have a sample sheet
I have a module that runs through the list in a loop within another loop, checking for duplicate names and then grouping the names together to send an email with an attachment based on Column D (Division).
Sample 4 would get one email with 3 attachments.
I have been asked to build in the ability to exclude people based on a value (I chose yes or no, column C) before running the module.
Reason being that if the list is long (over 1000 names) to set it before generating the emails. I would build in a trigger to set that value, but it is apparently an arbitrary decision made by the senders in a dept.
I have tried to build an IF statement into the loop as shown below but it is as if the If statement is coming out as not being true (I stepped through).
Which means all the With Outmail objects will not work.
I was able to get it to work by using the if statement with a for/next setup on its own (no loops), but cannot get it to work with the loop, which is the more important piece.
Here is the main piece of code. The main loop and then the if statement to account for the yes or no values:
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
And here is the full sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
If rng.Cells(r, 3).Value Like "?*#?*.?*" And LCase(rng.Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
End If
Set strName = rng.Cells(r, 1)
Set strDept = rng.Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = rng.Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = rng.Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
Loop
.Display
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
Figured it out, here is the final sub:
Sub EmailDivisions()
Dim OutApp As Object
Dim OutMail As Object
Dim cell, lookrng As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strBody As String
Dim strName As Variant
Dim strName1 As Variant
Dim strDept As Variant
Dim strName2 As String
Dim strName3 As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Divisions.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Set rng = ActiveSheet.UsedRange
r = 2
Do While r <= rng.Rows.Count
Debug.Print LCase(rng.Cells(r, 2))
If Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
ElseIf Cells(r, 2).Value Like "?*#?*.?*" And LCase(Cells(r, 3)) = "no" Then GoTo ContinueLoop
End If
Set strName = Cells(r, 1)
Set strDept = Cells(r, 4)
strName2 = Left(strName, InStr(strName & " ", " ") - 1)
With OutMail
strFilename = Dir("\\Divisons\1a*" & strDept & "*")
.SentOnBehalfOfName = "divisionalsend#xyz.org"
.To = Cells(r, 2).Value
.Subject = "Monthly Divisional Report for " & strDept
.HTMLBody = "<Font Face=calibri>" & "Dear " & strName2 & ",<br><br>" & signature
.Attachments.Add strDir & strFilename
.display
'See if the next row is for the same sender. If so, process that
'row as well. And then keep doing it until no more rows match
Do While rng.Cells(r, 2).Value = rng.Cells(r + 1, 2)
r = r + 1
Set strDept = Cells(r, 4)
strfilename1 = Dir("\\Divisions\1a*" & strDept & "*")
.Subject = "Monthly Divisional Report for Your Departments"
.Attachments.Add strDir & strfilename1
.Display
ContinueLoop:
Loop
End With
Set OutMail = Nothing
r = r + 1
Loop
Set OutApp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim FSO As Object
Dim ts As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set ts = FSO.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function

Resources