I want to send an automatically from Excel as it is running reports, but I need it to do a VLOOKUP on the client name and select all email addresses that are assigned to that client. Can you help please?
So I will have a table such as below, on a sheet named Client Emails
Company 1 | example#mail.com
Company 1 | example2#mail.com
Company 2 | somebody#somewhere.com
Company 3 | you#here.com
Company 1 | him#there.com
to make it easier to keep up to date. Right now I have the below code which sends the email correctly, but I would like it to pull the addresses from workbook and not the code as it is easier to update this way.
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "example#mail.com; example2#mail.com"
.CC = ""
.BCC = ""
.Subject = "Subject"
.Body = "Hello World."
.Attachments.Add ("Attachment")
'.Display
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
You could set up a loop to look through the table of email address and concatenate the emails of matching companies into a string variable which you then use for the "to" section.
For example (inserted prior to your with statement):
Dim Lastrow as long
dim myemail as string
dim myrange as Range
'counts the number of rows in use
lastrow = Sheets("Client Emails").Cells(Rows.Count, 1).End(xlUp).Row
For Each myrange In Sheets("Client Emails").Range("A2:A" & lastrow)
If myrange = "Company1" then
myEmail = myEmail & myrange.offset(0,1).value & ";"
End if
Next Myrange
You would replace "Company1" in the above to be the name of the company you were currently emailing.
The in your existing code replace:
.To = Email1, Email2,email3, .........
With
.To = myEmail
company = cells(1,2) ' Assign the source cell value of company name like VLOOKUP reference
a = 2
do while cells(a,1)<>""
if company = cells(a,1) then tolist = cells(a,2) 'IF condition matches, To mail list will be assigned to tolist
a = a +1
loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = tolist
.CC = ""
.BCC = ""
.Subject = "Subject"
.Body = "Hello World."
.Attachments.Add ("Attachment")
'.Display
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Related
I'm working on a way to send emails to a list of recipients. All emails should contain the same body, but with unique attachments. The code I'm using successfully retrieves the addresses from column N, and inserts attachments based on paths in corresponding rows in columns O:AZ.
The issue I'm encountering is that the first email created using the code has no body. The recipient and attachments are correct, but the email itself is empty. All other emails created show the body correctly. I have very little experience with VBA, and cannot find what's causing the issue.
Any help regarding the code and possible issues would be appreciated! Please let me know if you need more details regarding the code or data.
Sub create_emails()
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim strobody As String
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet2")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("N").Cells.SpecialCells(xlCellTypeConstants) 'email addresses located in Sheet2, column N
Set rng = sh.Cells(cell.Row, 1).Range("O1:AZ1") 'File paths stored in corresponding rows, columns 0:AZ
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
If Trim(FileCell) <> "" Then
If Dir(FileCell.Value) <> "" Then
.Attachments.Add FileCell.Value
End If
End If
Next FileCell
.Display 'Or use .Display / .Send
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You're setting strbody after you're using it, so the first time it's used it's empty.
Change:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
.Body = strbody
strbody = "Test text"
To:
With OutMail
.SentOnBehalfOfName = "xxx#xxx.xxx"
.To = cell.Value
.Subject = "test subject"
strbody = "Test text"
.Body = strbody
And also, if you had Option Explicit set, you'd notice that your declaration for strbody is mistyped to strobody.
I am trying to use the standard code to email a workbook to multiple recipients but build in some error handling that is likely to arise in my model.
If the email address is not available the cell where the email address would be found would read "Pending Search...".
If that is the case the loop simply needs to skip that cell and move on the the next email address.
Below is my code. The issue is coming from the IF/Then/Next line. I am getting a Next without For error. Any input would be greatly appreciated.
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim Position_In_Loop As Long
Dim Total_Emails As Long
Dim Email_Address As String
Dim Dashboard As Worksheet
Set Dashboard = ActiveWorkbook.Worksheets("Dashboard")
Dim Body As Range
Set Body = Dashboard.Range("F13")
Dim Attachment As Range
Set Attachment = Dashboard.Range("F24")
With Dashboard
Total_Emails = Dashboard.Range("G3")
End With
For Position_In_Loop = 1 To Total_Emails
Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0)
If Email_Address = "Pending Search..." Then Next Position_In_Loop
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email_Address"
.CC = ""
.BCC = ""
.Subject = "Open Job Violations"
.Body = "Body"
.Attachments.Add (Attachment)
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
Next Position_In_Loop
End Sub
You shouldn't increment the loop like that. You are going to skip emails. Wrap the whole the Outlook mail code in an If statement.
Option Explicit
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Dim Position_In_Loop As Long
Dim Total_Emails As Long
Dim Email_Address As String
Dim Dashboard As Worksheet
Set Dashboard = ActiveWorkbook.Worksheets("Dashboard")
Dim Body As Range
Set Body = Dashboard.Range("F13")
Dim Attachment As Range
Set Attachment = Dashboard.Range("F24")
With Dashboard
Total_Emails = Dashboard.Range("G3")
End With
For Position_In_Loop = 1 To Total_Emails
Email_Address = Dashboard.Range("C3").Offset(Position_In_Loop, 0)
If Email_Address <> "Pending Search..." Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "Email_Address"
.CC = ""
.BCC = ""
.Subject = "Open Job Violations"
.Body = "Body"
.Attachments.Add Attachment
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next Position_In_Loop
End Sub
change this line
If Email_Address = "Pending Search..." Then Next Position_In_Loop
to
If Email_Address = "Pending Search..." Then
Position_In_Loop=Position_In_Loop+1
end if
I am using the already known Subroutine to send a warning email to outlook whenever a condition is met.
In the routine I define an string array under the name DatePassed in which I store some dynamical values and I intent to return it's content in the Subject of the email.
The problem is that I don't know how exactly to handle DatePassed so to return me the whole array not just the first element.
How would I do this?
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Dim DatePassed(100) As Variant
Dim i As Integer
For i = 6 To 13
If Cells(i, 1) < Date Then
DatePassed(i - 6) = Cells(i, 2)
End If
Next i
With OutMail
.To = "Joerge#Johnson.com"
.CC = "James#Johnson.com"
.BCC = ""
.Subject = "Unmanaged Clients"
.Body = DataPassed
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Try this.
I have just added a Loop to run through the Array and stored it as a string which then gets assigned to the .Body
Sub Mail_workbook_Outlook_1()
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Dim DatePassed(100) As Variant
Dim i As Integer
For i = 6 To 13
If Cells(i, 1) < Date Then
DatePassed(i - 6) = Cells(i, 2)
End If
Next i
'=================================================
'New Section
Dim DataPassedElementReference As Long
Dim DataPassedString As String
DataPassedString = ""
'Using 100 as this is waht you used to define the array
For DataPassedElementReference = 1 To 100
DataPassedString = DataPassedString & DataPassed(DataPassedElementReference) & " "
Next DataPassedElementReference
'=================================================
With OutMail
.To = "Joerge#Johnson.com"
.CC = "James#Johnson.com"
.BCC = ""
.Subject = "Unmanaged Clients"
'Note the difference here
'.Body = DataPassed
.Body = DataPassedString
.Attachments.Add ActiveWorkbook.FullName
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I can send a single Outlook message using Excel VBA. However, I want to loop through my rows and send an email for each row that meets a certain condition.
Unfortunately, when I put the email code in a for loop only one email gets sent or none at all (depending on how I structure the code).
Is there something about calling Outlook multiple times that I should know?
Private Sub CommandButton1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
For Each cell In contactRange
If Range(Cells(cell.Row, cell.Column).Address).Value = "Yes" Then
nextAddy = Range(Cells(cell.Row, cell.Column).Address).Offset(0, 5).Value
toAddy = nextAddy & ", " & toAddy
End If
Next cell
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2)
End If
For i = 0 To 1 'short loop for testing purposes
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next i
End Sub
Take the CreateObject line out of the loop:
Set OutApp = CreateObject("Outlook.Application")
For i = 0 To 1 'short loop for testing purposes
Set OutMail = OutApp.CreateItem(0)
...
I've tried to clean up your logic stream but there are many unanswered questions due to the lack of sample data, explicit error messages and output.
Private Sub CommandButton1_Click()
Dim outApp As Object
Dim outMail As Object
Dim myValue As Variant
Dim contactRange As Range
Dim cell As Range
Dim toAddy As String, nextAddy As String
Dim i As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Me.Range("ContactYesNo")
myValue = InputBox("Enter body of email message.")
With Worksheets(contactRange.Parent.Name) '<~~ surely you know what worksheet you are on..!?!
For Each cell In contactRange
If cell.Value = "Yes" Then 'no need to define a range by the range's address
nextAddy = cell.Offset(0, 5).Value 'again, no need to define a range by the range's address
toAddy = nextAddy & ";" & toAddy 'use a semi-colon to concatenate email addresses
End If
Next cell
End With
If Len(toAddy) > 0 Then
toAddy = Left(toAddy, Len(toAddy) - 2) 'I have no idea why you need to shorten the toAddy by 2
'only send mail where one or more addresses exist
For i = 0 To 1 'short loop for testing purposes
Set outMail = outApp.CreateItem(0)
With outMail
.To = toAddy
.CC = ""
.BCC = ""
.Subject = "test email"
.Body = myValue
.Send
End With
Set outMail = Nothing
Next i
End If
Set outApp = Nothing
End Sub
OK, so I re-wrote the code based on the feedback. I used a loop to send emails one at a time instead of concatenating the addresses together as I wanted to personalize each email. I also needed to create a form to handle the input as inputbox only accepts 256 characters.
A form was pretty much required as I needed to capture the subject line, message body, salutation, path the to the attachment etc.:
Private Sub CommandButton1_Click()
Dim subject As String, msg As String, path As String
subject = TextBox1.Value
msg = TextBox2.Value & vbCrLf & vbCrLf & "Sincerely," & vbCrLf & TextBox4.Value & vbCrLf & TextBox5
path = TextBox3.Value
UserForm1.Hide
Module1.sendEmail subject, msg, path
End Sub
I placed the email code in Module1. Note, be sure to set the .sentOnBehalfOfName attribute or Outlook will simply pick an account which may not be the one you want if you have multiple accounts registered:
Public Sub sendEmail(subject As String, msg As String, path As String)
Dim outApp As Object
Dim outMail As Object
Dim contactRange As Range, cell As Range
Dim toAddy As String, emailMsg As String
Dim count As Integer
Set outApp = CreateObject("Outlook.Application")
Set contactRange = Range("ContactYesNo")
With Worksheets("IT consulting")
For Each cell In contactRange
If cell.Value = "Yes" Then
count = count + 1
toAddy = cell.Offset(0, 6).Value
emailMsg = "Dear " & cell.Offset(0, 2).Value & "," & vbCrLf & vbCrLf & msg
Set outMail = outApp.CreateItem(0)
With outMail
.SentOnBehalfOfName = "me#someemail.com"
.To = toAddy
.CC = ""
.BCC = ""
.subject = subject
.Body = emailMsg
.Attachments.Add path
'.Display
.Send
End With
'log the action
cell.Offset(0, 1).Value = Now & vbCrLf & cell.Offset(0, 1).Value
End If
Set outMail = Nothing
Next cell
End With
Set outApp = Nothing
MsgBox "total emails sent: " & count
End Sub
I have the following code which lets me prepare an email which is ready to be sent:
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ThisWorkbook.Sheets("Users").Range("A1").Value
.CC = ""
.BCC = ""
.Importance = 2
.Subject = "[ACTION REQUIRED] Format(Date, "YYYYMMDD")"
.HTMLBody = "some_body"
.Display
End With
and here is the Users table:
Users Johnson, Jerry Mullen, Carl Mullen, Carl Mullen, Carl Terry, Mark Carlos, Juan
I need to create a macro which lets me prepare an email but my main problem is I don't know how to add recipients using data from Users table.
My current code is not allowing me to attach anything aside from string values (typed directly, or maybe I'm doing something wrong).
I also need it to not attach names that are duplicated.
The following code assumes that you have your users' names in your outlook contact list, and that they are located in the cells A2 and down, but that range can be altered.
Sub test()
Dim users As New Collection
Dim usrRng As Range
Dim recipients As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set usrRng = Range("A2", Range("A2").End(xlDown))
Application.ScreenUpdating = False
On Error Resume Next
For Each cell In usrRng
users.Add cell.Value, cell.Value
Next cell
On Error GoTo 0
For Each usrName In users
recipients = recipients & usrName & "; "
Next usrName
With OutMail
.To = recipients
.CC = ""
.BCC = ""
.Importance = 2
.Subject = "[ACTION REQUIRED] " & Format(Date, "YYYYMMDD")
.HTMLBody = "some_body"
.Display
End With
Application.ScreenUpdating = True
End Sub
What this does, is that it takes each name in the range A2 and down, and adds it to a collection, skipping the duplicates.
Then we make a string, which will be made out of each name we just added to the collection, seperating each name with a ";".
Then we pass that new string to the OutMail object as the receiver of the message.
When the new mail is displayed, the names will not be recognized, but if press send, the mail should be sent to the correct people, assuming you don't have multiple contacts with the same name.