I have a path T:\Fin\Reports\Final Reports
I save different reports for groups each month. The file get saved as the group names: Acct, Pal, Mg, Qrt, etc.
I have a chart where I plan to build my VBA that has in Cell G2, the group code and in Cell H2 the email address the files need to be sent to.
For instance:
Cell G2 = Acct
Cell H2 = Tim.Doe#Company.com
Cell G3 = Pal
Cell H3 = Jane.Doe#Company.com
I have this stock code for creating an email. How do I implement a for loop so it cycles through all the files in the folder and creates an individual email to each group and is addressed to the right email address?
Set xOutlookObj = CreateObject("Outlook.Application")
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.Display
.To = Range("H2")
.CC = ""
.Subject = "Monthly Report"
.Attachments.Add ??????
End With
Soemthing like this:
Const FPATH As String = "T:\Fin\Reports\Final Reports\"
Dim rw As Range, xOutlookObj, xEmailObj, attPath
Set xOutlookObj = CreateObject("Outlook.Application")
Set rw = Thisworkbook.Worksheets("Info").Range("G2:H2")
do while application.counta(rw) = 2 'loop over rows while have content
Set xEmailObj = xOutlookObj.CreateItem(0)
With xEmailObj
.To = rw.cells(2).value
.CC = ""
.Subject = "Monthly Report"
attPath = FPATH & rw.cells(1).value & ".xlsx"
Debug.Print rw.cells(2).value, attPath
.Attachments.Add attPath
.Display
End With
Set rw = rw.offset(1, 0)
loop
Related
I have a macro to draft automatic emails based on the recipients in each columns.
However, I'm looking for a code which can if the attachments named in the excel sheet are attached to the email. If there is any attachment missing from that email it should show a msg box with the name of the missing attachment.
SNip of one the sheets attached
Sub Email1()
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")
Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)
Dim FLNM As String
Dim AttchmentName As String
Set AddressList = Sheets("Tracker Summary").Range("Y:Z")
Dim AttchmentName1 As String
Dim path As String
Call FetchFileNames
path = ThisWorkbook.path & "/"
Dim i As Integer
i = 5
With olMail
ActiveSheet.Range("A1").Select
.BodyFormat = olFormatHTML
.Display
.To = ActiveSheet.Cells(2, i).Value
.CC = ActiveSheet.Cells(3, i).Value
.Subject = ActiveSheet.Cells(4, i).Value
.HTMLBody = ActiveSheet.Cells(5, i).Value & .HTMLBody
j = 6
Do Until IsEmpty(Cells(j, i))
On Error Resume Next
FLNM = ActiveSheet.Cells(j, i).Value
AttchmentName1 = Application.WorksheetFunction.VLookup(FLNM, AddressList, 1, True)
If FLNM = AttchmentName1 Then
AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
.Attachments.Add AttchmentName
End If
j = j + 1
Loop
'.Display
End With
Sheets("Tracker Summary").Range("Y:Z").ClearContents
End Sub
Presuming that AttachmentName is a full file path string, maybe your code could check if the file exists beforehand.
For the sake of simplicity...
If Len(Dir(AttachmentName)) = 0 then msgbox "The File " & AttachmentName & " is missing"
... Just after you set AttachmentName value at AttchmentName = Application.WorksheetFunction.VLookup(FLNM, AddressList, 2, True)
Obviously, same for any other Attachment variables.
I have got a workbook with 4 sheets:
1st - recipients email data such as TO, CC, Subject, from 2nd to 4th
the sheets which I need to send as an attachment to the recipients.
I made up the following script. But I faced 2 issues as a VBA beginner:
The 'loop' proposes for sending the 1st empty row from the 1st sheet
as well (I would like to stop with the last email details);
The 'ActiveWorkbook' sends all sheets (I would like to skip the 1st
one where the recipients & the VBA script are located);
I appreciate every advice/remark because I have been studying VBA for 3 months.
Thank you in advance!
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add ActiveWorkbook.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
End Sub
Have a look at this. This takes a copy of your workbook and saves it to the users "temp" location. It then does the modifications that you want to the copy of the workbook before attaching that.
Sub ICO_Emails()
Dim VSEApp As Object
Dim VSEMail As Object
Dim VSEText As String
Dim Email_Send_To, Email_Cc, Email_Subject As String
Dim wb As Workbook, nwb As Workbook
Application.ScreenUpdating = False
Set wb = ThisWorkbook
wb.SaveCopyAs (Environ("temp") & "\temp_" & wb.Name)
Set nwb = Workbooks.Open(Environ("temp") & "\temp_" & wb.Name)
With nwb
Application.DisplayAlerts = False
' Delete relevant sheet
.Sheets(1).Delete
Application.DisplayAlerts = True
.Save
End With
row_number = 1
Do
DoEvents
row_number = row_number + 1
Email_Send_To = Sheet1.Range("A" & row_number)
Email_Cc = Sheet1.Range("B" & row_number)
Email_Subject = Sheet1.Range("C" & row_number)
On Error GoTo debugs
Set VSEApp = CreateObject("Outlook.Application")
Set VSEMail = VSEApp.CreateItem(0)
'Email Body script
VSEText = "<BODY style=font-size:14pt;font-family:Times New Roman>Dear all,<p>Test.<p></BODY>"
'Email Signature
With VSEMail
.Display
End With
Signature = VSEMail.HTMLBody
With VSEMail
.To = Email_Send_To
.CC = Email_Cc
.Subject = Email_Subject
.HTMLBody = VSEText & Signature
.Attachments.Add nwb.FullName
.Display
End With
debugs:
Loop Until Email_Send_To = ""
nwb.Close
Application.ScreenUpdating = True
End Sub
Save a copy of your workbook
Open it
Remove the sheet from the copy
Save
Send this edited workbook
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.
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