Ladies and Gentlemen,
Good afternoon. I have been a long time lurker however this is my first time posting. So far this site has been a great help in getting me to where I currently am and for that I thanks you. I'm posting because I'm stuck and my brain is fried from trying to figure this out. I have been using Excel, MS Word and Outlook to send bulk personalized emails for some time now. In an attempt to cut out the middle man (sorry, MS Word...) I found that I can use Excel to achieve the results I'm looking for.
What I'm currently able to do:
I can currently send a personalized email to everybody with a column. Please see code below.
Sub SendBulkEmails() 'Variable declaration Dim OutApp As Object Dim OutMail As Object Dim str1 As String Dim str2 As String Dim FirstNm As String Dim LastNm As String Set OutApp = CreateObject("Outlook.Application") Set w = ThisWorkbook 'Read details from Excel sheet and send emails 'Get the "Lead Refinement" sheet w.Sheets("Lead Refinement").Activate Set lr = w.Sheets("Lead Refinement") 'Activate the sheet so you can get a Range from it lr.Activate 'Get the "active" rows ar = lr.UsedRange.Rows.Count 'Display the number of "active" rows 'This number will always have 9 more than the number of leads '(the 9 rows of header info in that sheet) 'Debug.Print ("Active Rows:" & ar) 'The Range we want always starts with B10 and ends with H[LASTROW], 'where LASTROW = number of active rows - 9 Set leadRange = lr.Range("B10:P" & ar) 'Debug.Print ("Range Rows:" & leadRange.Rows.Count) For Each r In leadRange.Rows If r.Cells(6) <> "" Then ''Displaying the value of the first cell in every Row in the Range 'Debug.Print (r.Cells(1).Value) Set OutMail = OutApp.CreateItem(0) LastNm = r.Cells(2).Value FirstNm = r.Cells(3).Value str1 = Sheet3.Range("B18").Value str1 = Replace(Sheet3.Range("B18").Value, "#First_Name#", FirstNm) str2 = str1 str2 = Replace(str2, "#Last_Name#", LastNm) With OutMail .To = r.Cells(8).Value .Subject = Sheet3.Range("B14").Value .Body = str2 If (Sheet3.Range("B16").Value) <> "" Then .Attachments.Add (Sheet3.Range("B16").Value) Else End If If Sheet5.Range("C2").Value = True Then .Display Else .Save End If End With End If Next r End Sub
What I'm trying to do:
There are some people that I will be emailing that have up to eight different email addresses. I need to send one email to each of the address. I need to avoid putting all eight addresses in the same email on the To Line
Last Name - Column C, First Name - Column D, Email Addresses - I:P
If Peter is on the first row, I would like to sent all eight emails to Peter before moving to the second row and sending all eight emails to Paul. My list of people to send emails to could extend into the thousands of rows and potentially 10's of thousands.
I want to thank everybody in advance for even taking a look at this thing and your help is greatly appreciated.