So I'm in need of some help. I'm trying to update my company's Excel tool that they use to manage clients. I currently need help with updating the Send Email function of the tool. So employees will have a list of clients they need to send an email to, and each client will have specific information like name, client number, etc., and the employees should be able to click the "Send Email" macro button that's built in, and different emails will populate in Outlook with the specific info for each client built into the Email recipient, Title and Body.
I am currently stuck. For example, I will choose 3 clients to send an email to, click the "Send Email" button, and I will get 3 emails to populate (as I should). The first email will have all of the correct info in the right place for Client #1. However, Email #2 will have the correct Email Recipient & Email Title, but then the Email Body will have the correct info for Client #2, and below that also in the Email Body will be all of the email body info for Client #1. And same for Email #3, it will have the correct recipient and title, but the Body will have body info for Client #3, then Client #2, then Client #1.
So I know that I need to fix it through some sort of loop for the email body, but I have been working on this for so long I just can't see it anymore. I've removed any sensitive information and put in placeholders, but I think you should get the idea.
Please let me know if you have any questions.
Sub SendEMail()
Dim Email As String
Dim Subj As String
Dim Msg As String
Dim URL As String
Dim r As Integer
Dim x As Double
Dim OApp As Object
Dim OMail As Variant
Dim Signature As String
Dim strbody As String
strbody = "<html><body>"
With Sheets("Email").Select
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
End With
For r = 2 To lastrow
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
' Get the email address
Sheets("Email").Select
Email = Cells(r, "F")
' Message subject
Sheets("Email").Select
Subj = "Renewal for " & Cells(r, "B").Text & " Contract " & Cells(r, "A").Text & " Effective " & Cells(r, "C").Text
' Message body
Sheets("Email").Select
strbody = strbody & "Dear " & Cells(r, "AR").Text & ", <br><br>" & _
"I will be working with you on " & Cells(r, "B") & ", client number " & Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _
"For this year's contract, we are requesting the following information: <br>" & _
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _
"The application form may be downloaded from:<br>" & _
"<li>Option #1</li>: " & "" & "Link#1" & "" & "<br>" & _
"<li>Option #2</li>: " & "" & "link#2" & "" & "<br><br>" & _
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _
"As always, we would like to thank you for your business. <br><br>" & _
"Regards, <br>"
On Error Resume Next
Sheets("Email").Select
With OMail
.Display
.To = Email
.Subject = Subj
.HTMLBody = strbody & vbNewLine & .HTMLBody
End With
Next r
On Error GoTo 0
Set OMail = Nothing
Set OApp = Nothing
End Sub
Please take a look at this example.
In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)
The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.
Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set sh = Sheets("Sheet1")
Set OutApp = CreateObject("Outlook.Application")
For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
'Enter the path/file names in the C:Z column in each row
Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")
If cell.Value Like "?*#?*.?*" And _
Application.WorksheetFunction.CountA(rng) > 0 Then
Set OutMail = OutApp.CreateItem(0)
With OutMail
.to = cell.Value
.Subject = "Testfile"
.Body = "Hi " & cell.Offset(0, -1).Value
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
.Send 'Or use .Display
End With
Set OutMail = Nothing
End If
Next cell
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
You can learn more about it from the link below.
http://www.rondebruin.nl/win/s1/outlook/amail6.htm
If you want to use this macro instead of a mail merge the problem you are having is here:
strbody = strbody & "Dear " & Cells(r, "AR").Text & ", <br><br>" & _
"I will be working with you on " & Cells(r, "B") & ", client number " & Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _
"For this year's contract, we are requesting the following information: <br>" & _
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _
"The application form may be downloaded from:<br>" & _
"<li>Option #1</li>: " & "" & "Link#1" & "" & "<br>" & _
"<li>Option #2</li>: " & "" & "link#2" & "" & "<br><br>" & _
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _
"As always, we would like to thank you for your business. <br><br>" & _
"Regards, <br>"
This takes the variable strbody and adds the rest of the string to it.
Update it to:
strbody = "Dear " & Cells(r, "AR").Text & ", <br><br>" & _
"I will be working with you on " & Cells(r, "B") & ", client number " & Cells(r, "A") & ", which is effective " & Cells(r, "C") & ".<br><br>" & _
"For this year's contract, we are requesting the following information: <br>" & _
"<li>" & Cells(r, "AH") & "</li>" & "<br><br>" & _
"The application form may be downloaded from:<br>" & _
"<li>Option #1</li>: " & "" & "Link#1" & "" & "<br>" & _
"<li>Option #2</li>: " & "" & "link#2" & "" & "<br><br>" & _
"Once we receive the requested information, you will receive your contract within 5 business days. Should you have any questions, please don't hesitate to contact me at this email address or phone number <br><br>" & _
"As always, we would like to thank you for your business. <br><br>" & _
"Regards, <br>"
And it will overwrite it each time which is what I think you want.
Also you don't need to select the sheet each time (or at all really). Selecting sheets, cells, etc is generally bad coding practice that can significantly slow down your code.
Related
I need a piece of code I can use to create a Macro that outputs each row of my spreadsheet below as an individual Outlook email, to the email address in the column titled "Email" below. I also need to add the columns titled, "Call", "Type", "Balance" and "Company Name" to the the body of the email.
I also need to add some free text to my email which is the same for each email sent: Body of email
The following procedure should accomplish this task. It is assumed that your data is stored in the columns A:G. If this is not the case, you will need to modify the specific parts accordingly. In addition, the code already includes the feature that the subject-varying part of the "body of the e-mail" is already in bold face.
Importantly, in its current state, the code only creates and displays the e-mails. If you want to send them, you need to change this part of the code from .Display to .Send (see comment in the code):
Sub sendOlMail()
Application.ScreenUpdating = False
Dim ws As Worksheet, olApp, olMail As Object, cell As Range, lr As Long, i As Integer, strBody1, strBody2 As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set olApp = CreateObject("Outlook.Application")
lr = Cells(Rows.Count, "G").End(xlUp).Row 'determine row with last value for loop
strBody1 = "Dear Sir/Madam,<br/><br/>" _
& "We are still awaiting payment from you for: <br/><br/>"
strBody2 = "Please can you provide us with an update? We have recently resent out invoice/card payment links as a gentle reminder. <br/><br/>" _
& "Please note it is a legal requirement for anyone using wireless radio equipment to hold a valid licence. On occasions we carry out site visits to ensure that any frequencies being used for wireless radio equipment are being used legally. <br/><br/>" _
& "Unfortunately, we may also have to look at revoking your company’s access to our Online Portal until such time as this payment is made. <br/><br/>" _
& "Kind Regards, Joe Bloggs"
For i = 2 To lr
Set olMail = olApp.CreateItem(0)
With olMail
.To = Range("G" & i).Value
.Subject = "E-Mail Subject" 'adjust subject of your e-mail
.htmlBody = strBody1 & "<b>" _
& Range("A" & i).Value & ", " & Range("C" & i).Value & ", " & Range("D" & i).Value & ", " & Range("E" & i).Value & "</b>" & "<br/><br/>" _
& strBody2
.Display 'change to .Send if you want to send out the e-mail
End With
Set olMail = Nothing
Next i
Application.ScreenUpdating = True
End Sub
EDIT: Adding additional functionality to the code based on comment
1: I have modified the .htmlBody element so that it also contains the headers of the respective categories. Instead of hard-coding the names of the headers, I take the headers directly from the Excel file (first row in the respective columns). The advantage of this specification is that it is dyanmically specified, which means that if you change the name of your heading in the Excel file, it will be automatically reflected.
2: Including the signature is a bit more tricky, but there are several ways to accomplish this. For this step, you should make sure that you specify your signature outside the loop, otherwise this will cause unnecessary overhead. You should also make sure that you declare your signature as a string variable.
(I) Retrieving the signature from the Outlook folder. This is a bit more complicated, but for me the better solution since the formatting of the signature is preserved (I have included this approach in the updated code).
(II) Retrieving the signature from the body of an email. The disadvantage of this method is that the formatting specified by the user is not preserved. However, if this is not an issue, this could be an even simpler solution. Then simply change the signature-related parts of the code with the following parts:
Set olMail = olApp.CreateItem(0)
olMail.Display
signature = olMail.Body
Set olMail = Nothing
The code with the additional functionalities (i.e., inclusion of headers and signature) looks as follows:
Sub sendOlMail()
Application.ScreenUpdating = False
Dim ws As Worksheet, olApp, olMail As Object, cell As Range, lr As Long, i As Integer, strBody1, strBody2, signature As String
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set olApp = CreateObject("Outlook.Application")
lr = Cells(Rows.Count, "G").End(xlUp).Row 'determine row with last value for loop
' prepare signature
signature = Environ("appdata") & "\Microsoft\Signatures\"
If Dir(signature, vbDirectory) <> vbNullString Then signature = signature & Dir$(signature & "*.htm") Else signature = ""
signature = CreateObject("Scripting.FileSystemObject").GetFile(signature).OpenAsTextStream(1, -2).ReadAll
strBody1 = "Dear Sir/Madam,<br/><br/>" _
& "We are still awaiting payment from you for: <br/><br/>"
strBody2 = "Please can you provide us with an update? We have recently resent out invoice/card payment links as a gentle reminder. <br/><br/>" _
& "Please note it is a legal requirement for anyone using wireless radio equipment to hold a valid licence. On occasions we carry out site visits to ensure that any frequencies being used for wireless radio equipment are being used legally. <br/><br/>" _
& "Unfortunately, we may also have to look at revoking your company’s access to our Online Portal until such time as this payment is made. <br/><br/>" _
& "Kind Regards, Joe Bloggs"
For i = 2 To lr
Set olMail = olApp.CreateItem(0)
With olMail
.To = Range("G" & i).Value
.Subject = "E-Mail Subject" 'adjust subject of your e-mail
.htmlBody = strBody1 & "<b>" _
& Range("A" & 1).Value & ": " & Range("A" & i).Value & ", " _
& Range("C" & 1).Value & ": " & Range("C" & i).Value & ", " _
& Range("D" & 1).Value & ": " & Range("D" & i).Value & ", " _
& Range("E" & 1).Value & ": " & Range("E" & i).Value & "</b>" & "<br/><br/>" _
& strBody2 & "<br/><br/>" _
& signature
.Display 'change to .Send if you want to send out the e-mail
End With
Set olMail = Nothing
Next i
Application.ScreenUpdating = True
End Sub
In excel I have a list of departments on a worksheet named "Weekly Changes"
There are multiple departments but only FY22 and FY23 all set up the same way going down the worksheet.
I have VBA set up to create and email, and I want to be able to find all the changes from weekly changes that are more than 10% in Column E and list them in the email
Email exmple:
Hello All,
Weekly Changes:
Department 1 - FY23 - Product A 11%
Department 2 - FY22 - Product A 15% - Product C 94%
FY23 - Product B 23% - Product C 11%
Thank You,
ME
Is this possible or can someone help me get anywhere even close to this?
VBA I'm using to create email that is located in a module on the workbook containing the weekly changes work sheet:
Sub Email()
Dim OutLookApp As Object
Dim OutLookMailItem As Object
Set OutLookApp = CreateObject("Outlook.application")
Set OutLookMailItem = OutLookApp.CreateItem(0)
With OutLookMailItem
.Display
End With
EBody = "Hello All," _
& "<br><br>" _
& "Weekly Changes" & "<br>" _
& "List of Changes?" _
& "Thank You," & "<br>" _
& "ME"
With OutLookMailItem
.To = ""
.Subject = "Weekly Changes"
.HTMLbody = EBody
End With
End Sub
Okay so, we have our data already being nicely converted to line entries with some array formulas:
Store in array and check each value:
Add to email.
Option Explicit
Option Base 1
Sub Build_Email(ebody As String, eSubject As String, eRecipient As String)
Dim OLApp As Object
Dim OLMailItem As Object
Set OLApp = CreateObject("Outlook.application")
Set OLMailItem = OLApp.CreateItem(0)
With OLMailItem
.To = eRecipient
.CC = ""
.BCC = ""
.Subject = eSubject
.HTMLBody = ebody
.Display 'Only Use Display or Send and comment out the other
'.Send 'Only Use Display or Send and comment out the other
End With
End Sub
Sub Identify_Line_Entries_Over_10Percent()
Dim I As Integer 'Iteration
Dim LineEntries 'Array of all line entries
Dim ChangeList As String 'List of all changes > 10%
' > Store Line entries
LineEntries = Sheet1.Range("O3:T" & Range("T" & Rows.Count).End(xlUp).Row)
' > Cycle each line entry to check
For I = 1 To UBound(LineEntries, 1)
Debug.Print LineEntries(I, 6)
' > Check if change is > 10%
If LineEntries(I, 6) > 10 Then
ChangeList = ChangeList & _
" -) " & LineEntries(I, 1) & " - " & LineEntries(I, 2) & " - " & _
LineEntries(I, 3) & " - " & LineEntries(I, 4) & " - " & _
LineEntries(I, 5) & " - " & Format(LineEntries(I, 6), "0.00") & "% <br>"
End If
Next I
' >>> Passing all Variables to Email Sub
Build_Email _
"Hello All, <br><br>" & _
"Please note the below changes for your review: <br><br>" & _
ChangeList & "<br>" & _
"Thank You, <br><br>" & _
"ME", _
"Weekly Changes", _
"Someone#hotmail.com"
End Sub
And final output looks like this:
This code sends email. In the list sometimes a new employee does not have an email address yet. How can I skip creating an email if the .To in Cells(x,2) is blank and go to the Next x?
With OutMail
.To = Cells(x, 2)
.Subject = Cells(x, 3)
'Change Body for email message here
.Body = "Dear " & EmployeeName & "," & vbNewLine & vbNewLine & _
"Attached is a copy of your check stub for this week." & vbNewLine & vbNewLine & _
"Thank you," & vbNewLine & _
"Moe Ballout"
'Check if Attachment file exists, if not, then it will skip email
If Dir(filename, vbNormal) <> "" Then
.Attachments.Add (filename)
'.Display
.SendUsingAccount = OutApp.Session.Accounts(fromaccount)
.Send
End If
End With
Next
End Sub
If Len(Cells(x, 2)) > 0 Then
'your code that creates OutMail object
End If
I'm trying to set up a macro to send an email, updating people on a due date timeline. This email should pull dates from specific cells and place them into the message body. So far I'm able to set up the email to read the way I want, but am having trouble calling the dates.
I'm super new at vba and this may not be a function that's possible, but any workarounds would be appreciated! Thanks!
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Dim rev_1 As Date, rev_2 As Date, final_due As Date
rev_1 = Range(I2)
rev_2 = Range(K2)
final_due = Range(M2)
strbody = "XXXXXXX" & vbNewLine & vbNewLine & _
"This is an update on your project dates:" & vbNewLine & vbNewLine & _
"Review 1 Suspense: CALL CELL I2 HERE" & vbNewLine & _
"Review 2 Suspense: CALL CELL K2 HERE" & vbNewLine & _
"Final Due Date: CALL CELL M2 HERE" & vbNewLine & vbNewLine & _
"Acoording to this timeline, you are AHEAD/ON TIME/BEHIND." & vbNewLine & vbNewLine & _
"If you have any questions, please contact XXXX." & vbNewLine & vbNewLine & _
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "Upcoming Project - Timeline Update"
.Body = strbody
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
hello you could do like this
"Review 1 Suspense: " & range("I2") & vbNewLine & _
I have this code which sends out an email using outlook. I have multiple email accounts in outlook and I am trying to add in a way so i can tell it which email address to send it from? Can someone please show me how i can do this?
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = Range("AS1").Column Then
If Target.Row > 7 And Target.Value = "Send Email" Then
Range("AU" & Target.Row).Value = Date
End If
End If
If Target.Column = Range("CD1").Column Then
If Target.Row > 7 And Target.Value = "Notify" Then
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Dear " & Range("AE" & ActiveCell.Row) & "," & vbNewLine & vbNewLine & _
"This is an automated email, sent to you by the purchasing department." & vbNewLine & _
"We have an update on the status of your New Supplier Request. Please see the information below." & vbNewLine & vbNewLine & _
"Supplier Name: " & Range("B" & ActiveCell.Row) & vbNewLine & _
"Supplier Reference Number: " & Range("AG" & ActiveCell.Row) & vbNewLine & _
"Supplier Status: " & Range("D" & ActiveCell.Row) & vbNewLine & vbNewLine & _
"Description:" & vbNewLine & _
"We have successfully recieved your application and we have sent out our required documents to the supplier. Once these have been returned we will contact you with a further update. If you have any queries, please contact us at Purchasing#hewden.co.uk." & vbNewLine & vbNewLine & _
"What does this mean?" & vbNewLine & _
"We ask that all New Suppliers be registered to allow us to manage a more efficient supply chain. Right now you don't need to do anything else, we will contact the supplier and gather any additional information which we need. Please keep a note of your reference number in the event you should have any enquiries." & vbNewLine & vbNewLine & _
"Kind Regards," & vbNewLine & _
"Automated Purchasing Email"
On Error Resume Next
With OutMail
.to = Range("AF" & ActiveCell.Row)
.CC = "something#something.com"
.BCC = ""
.Subject = "New Supplier Request - Update"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With
On Error GoTo 0
End If
End If
End Sub
If you are using multiple POP3/SMTP accounts, set the MailItem.SendUsingAccount property to one of the accounts from the Namespace.Accounts collection.
If you are using Exchange, set the MailItem.SentOnBehalfOfName property - you must have an explicit permission to send on behalf of that user.
Try this
With OutMail
.SentOnBehalfOfName = "YourEmailAccount#Email.com"
.to = Range("AF" & ActiveCell.Row)
.CC = "something#something.com"
.BCC = ""
.Subject = "New Supplier Request - Update"
.Body = strbody
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.Send 'or use .Display
End With