I want to grab data from specified worksheets in an Excel workbook and then generate individual emails from each individual sheet.
Right now, the code will generate the first email from the first sheet then cycle through the remaining tabs without creating additional emails. I can confirm that the code is progressing beyond the first sheet via a MsgBox ActiveSheet.Name check.
I am leveraging Ron DeBruin's RangetoHtml function in a separate module.
Sub ClientEvent_Email_Generation()
Dim OutApp As Object
Dim OutMail As Object
Dim count_row, count_col As Integer
Dim Event_Table_Data As Range
Dim Event2_Table_Data As Range
Dim strl As String, STR2 As String, STR3 As String
Dim WS As Worksheet
Dim I As Integer
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
For Each WS In ThisWorkbook.Sheets
WS.Activate
If WS.Name <> "DATA INPUT" And WS.Name <> "FORMATTED DATA TABLE" And WS.Name <> "REP CODE MAPPING TABLE" And WS.Name <> "IDEAS TAB" And WS.Name <> "REFERENCE" Then
count_row = WorksheetFunction.CountA(WS.Range("A10", Range("a10").End(xlDown)))
count_col = WorksheetFunction.CountA(WS.Range("A10", Range("a10").End(xlToRight)))
Set Event_Table_Data = WS.Cells.Range(Cells(9, 1), Cells(count_row, count_col))
Set Event2_Table_Data = Sheets("w61").Range(Cells(9, 1), Cells(count_row, count_col))
str1 = "<BODY style=font-size:12pt;font-family:Times New Roman>" & _
"Hello " & Range("L3").Value & ",<br><br>The following account(s) listed below appear to have an upcoming event(s)<br>"
STR2 = "<br> Included are suggestions for an activity which may fit your client's needs.<br>"
STR3 = "<br> You may place an order, or contact us for alternate ideas if these don't fit your client."
On Error Resume Next
With OutMail
.To = WS.Range("l4").Value
.cc = ""
.bcc = ""
.Subject = "Upcoming Event In Your Clients' Account(s)"
.display
.HTMLBody = str1 & RangetoHTML(Event_Table_Data) & STR2 & RangetoHTML(Event2_Table_Data)& STR3 & .HTMLBody
.SEND
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox ActiveSheet.Name ‘Used for testing purposes only
End If
Next WS
End Sub
Related
I am trying to:
Use a value from Table A (column - person's name) to filter on Table B in separate sheet
Copy filtered Table B into the body of an email (outlook)
Send outlook email to email address for that recipient (from Table A)
Loop through the process again for the next person in Table A
Example of Table A:
Example of Table B:
So for example for the first iteration
Take Dave Jones from Table A and filter Table B for Dave Jones.
Copy the filtered Table B to the body of a new email
Send to Dave Jones (davejones#davejones.com).
Return to Table A for the next entry, in this case Anne Smith, and do the same. Repeat until the end of Table A.
I made code for setting up an email but this takes the whole worksheet and does not do any filtering. I am unable to work out how to put this loop together for multiple emails:
Sub SendWorkSheet_SENDEMAILS1()
Dim xFile As String
Dim xFormat As Long
Dim Wb As Workbook
Dim Wb2 As Workbook
Dim FilePath As String
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
On Error Resume Next
Application.ScreenUpdating = False
Set Wb = Application.ActiveWorkbook
ActiveSheet.Copy
Set Wb2 = Application.ActiveWorkbook
Select Case Wb.FileFormat
Case xlOpenXMLWorkbook:
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
Case xlOpenXMLWorkbookMacroEnabled:
If Wb2.HasVBProject Then
xFile = ".xlsm"
xFormat = xlOpenXMLWorkbookMacroEnabled
Else
xFile = ".xlsx"
xFormat = xlOpenXMLWorkbook
End If
Case Excel8:
xFile = ".xls"
xFormat = Excel8
Case xlExcel12:
xFile = ".xlsb"
xFormat = xlExcel12
End Select
FilePath = Environ$("temp") & "\"
FileName = Wb.name & Format(Now, "dd-mmm-yy h-mm-ss")
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
Wb2.SaveAs FilePath & FileName & xFile, FileFormat:=xFormat
With OutlookMail
.to = "EMAIL ADDRESS HERE"
.CC = ""
.BCC = ""
.Subject = "Suppliers"
.HTMLBody = "Hi all," & "<br>" & "<br>" & "Please find attached etc. etc." & "<br>" & "<br>" & "Kind regards," & "<br>" & "<br>" & "Sender"
'.Body = ""
.Attachments.Add Wb2.FullName
.Display
'.Send
End With
Wb2.Close
Kill FilePath & FileName & xFile
Set OutlookMail = Nothing
Set OutlookApp = Nothing
Application.ScreenUpdating = True
End Sub
I’ve had the need to do the task you describe a number of times in the past, and the following was the solution I came up with. Great credit to Sigma Coding at https://www.youtube.com/watch?v=ZlInSp0-MdU&ab_channel=SigmaCoding
for providing the bulk of the code – the Loop and Filter stuff I added for my own specific application.
For the following to work, you need to enable a couple of references within VBA. In the VBA Editor, select Tools/References & check the boxes ‘Microsoft Outlook 16.0 Object Library’ and ‘Microsoft Word 16.0 Object Library’. If they’re not already checked, you’ll find them listed alphabetically.
The following code suggestion assumes the following:
• The Managers’ list is on Sheet1 and the range they are contained in is called “MyRange”
• The table to filter is on Sheet2 and starts from cell A1
This code works for me – let me know how you go with it.
Option Explicit
Dim Outlook As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim OutInspect As Outlook.Inspector
Dim EmailTo As String
Dim OutWrdDoc As Word.Document
Dim OutWrdRng As Word.Range
Dim OutWrdTbl As Word.Table
Dim rng As Range, c As Range, MyRange As Range, myFilter As String
Sub TestEmail()
For Each c In Sheet1.Range("MyRange")
myFilter = c.Value
EmailTo = c.Offset(0, 1).Value
Sheet2.Range("A1:E1").AutoFilter Field:=2, Criteria1:="=" & myFilter
'ERROR TRAP
If EmailTo = "" Or Sheet2.Cells.SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then
GoTo Missing:
End If
Set rng = Sheet2.Cells.SpecialCells(xlCellTypeVisible)
On Error Resume Next
Set Outlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Set Outlook = New Outlook.Application
End If
Set OutMail = Outlook.CreateItem(olMailItem)
With OutMail
.To = EmailTo
.Subject = "Suppliers"
.Body = "Please find attached etc."
.Display
Set OutInspect = .GetInspector
Set OutWrdDoc = OutInspect.WordEditor
rng.Copy
Set OutWrdRng = OutWrdDoc.Application.ActiveDocument.Content
OutWrdRng.Collapse Direction:=wdCollapseEnd
Set OutWrdRng = OutWrdDoc.Paragraphs.Add
OutWrdRng.InsertBreak
OutWrdRng.PasteExcelTable Linkedtoexcel:=True, wordformatting:=True, RTF:=True
Set OutWrdTbl = OutWrdDoc.Tables(1)
OutWrdTbl.AllowAutoFit = True
OutWrdTbl.AutoFitBehavior (wdAutoFitWindow)
.Send
Application.CutCopyMode = False
Sheet2.AutoFilterMode = False
End With
Missing:
Next c
End Sub
I'm trying to fix one issue which is attaching a file.
I have a TABLE with list of people and their names and a condition(Y/N) column.
Column 1(Name) Column 2(Email) Column 3 (Condition Y/N)
I want to send emails to all people in the TABLE whose name matches with the unique values (name) in one of the columns in Sheet 1.
So I want something that looks up the column in Sheet 1 and maybe changes the Condition to Y in the TABLE for all unique names found in that Column in Sheet 1.(I can FILTER my TABLE in POWER QUERY to show only the rows with Condition "Y").
When the SINGLE email pops up (with the all people in the "To",) I want Sheet 1 or Sheet 2 to be attached to the email.
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table6").ListObject ' -> Set the table's name
On Error GoTo cleanup
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And _
LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
'You can add files also like this
'.Attachments.Add ("C:\test.txt") ' -> Adjust this path
.Display ' -> Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Code to Attach sheet 1 (doesn't work)
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
Worksheets("Sheet 1").Copy
ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
ActiveWorkbook.SaveAs Filename:= _
"H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1" & file_name_import, _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Attachments.Add "H:\Folder 1\Folder 2\Folder 3\Folder 4\File 1\" & file_name_import
I want to add code so my email pops up (with all required people in "To" and) with the attachment.
Option Explicit ' Consider this mandatory
' Tools | Options | Editor tab
' Require Variable Declaration
Public Sub AttachFileToEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim counter As Long
Dim toArray() As Variant
Dim strDir As String
Dim file_name_import As String
Dim fName As String
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
' Excel details not recreated, not needed for this question
file_name_import = Format(Now, "yyyy-mm-dd hh-mm-ss")
file_name_import = file_name_import & " - File 1.xlsx"
' Subscript out of range error would be bypassed due to poor error handling
'Worksheets("Sheet 1").Copy
Worksheets("Sheet1").Copy
' Trailing backslash error would be bypassed due to poor error handling
'ChDir "H:\Folder 1\Folder 2\Folder 3\Folder 4\"
strDir = "C:\Folder 1\Folder 2\Folder 3\Folder 4\"
Debug.Print strDir
' Backslash already at end of strDir
fName = strDir & "File 1" & file_name_import
Debug.Print fName
ActiveWorkbook.SaveAs FileName:=fName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
' Setup the email
Set OutMail = OutApp.CreateItem(0)
' Do not use On Error Resume Next without a specific reason for bypassing errors
' Instead fix the errors now that you can see them
With OutMail
' Excel details not recreated, not needed for this question
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please comply with the transfers in the attached file. " & _
"Look up for your store and process asap."
.Attachments.Add fName
.Display
End With
Set OutMail = Nothing
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The idea here is to copy the sheet to a new file and save it in you temp folder. Then attach it to your email
Option Explicit
Public Sub SendEmail()
' For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
' Working in Office 2000-2016
' Attachment code based on: http://www.vbaexpress.com/kb/getarticle.php?kb_id=326
' Adapted by Ricardo Diaz ricardodiaz.co
Dim OutApp As Object
Dim OutMail As Object
Dim sourceTable As ListObject
Dim evalRow As ListRow
Dim newBook As Workbook
Dim newBookName As String
Dim counter As Long
Dim toArray() As Variant
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set sourceTable = Range("Table1").ListObject
On Error GoTo Cleanup
' Save current file to temp folder (delete first if exists)
ThisWorkbook.Worksheets("Sheet1").Copy
Set newBook = ActiveWorkbook
newBookName = "AttachedSheet.xlsx"
On Error Resume Next
Kill Environ("temp") & newBookName
On Error GoTo 0
Application.DisplayAlerts = False
newBook.SaveAs Environ("temp") & newBookName
Application.DisplayAlerts = True
' Loop through each table's rows
For Each evalRow In sourceTable.ListRows
If evalRow.Range.Cells(, 2).Value Like "?*#?*.?*" And LCase(evalRow.Range.Cells(, 3).Value) = "yes" Then
ReDim Preserve toArray(counter)
toArray(counter) = evalRow.Range.Cells(, 2).Value
counter = counter + 1
End If
Next evalRow
' Setup the email
Set OutMail = OutApp.CreateItem(0)
With OutMail
' Add gathered recipients
For counter = 0 To UBound(toArray)
.Recipients.Add (toArray(counter))
Next counter
.Subject = "Reminder"
.Body = "Dear All" _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date"
'You can add files also like this
.Attachments.Add newBook.FullName ' -> Adjust this path
.Display ' -> Or use Display
End With
Set OutMail = Nothing
Cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
Let me know if it works
I have a workbook to send out email reminders based on the due date. I would like to change it such that the macro will run when I click a button instead of running automatically when it is opened.
ThisWorkbook:
Sub Workbook_Open()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
Next ws
End Sub
Module1:
Option Explicit
Dim Bcell As Range
Dim iTo, iSubject, iBody As String
Dim ImportanceLevel As String
Public Sub CheckDates(ws As Worksheet)
For Each Bcell In Range("a4", Range("a" & Rows.Count).End(xlUp))
' if email column is not empty then command continues
If Bcell.Offset(0, 15) <> Empty Then
' mail will not be sent if current time is within 23.7 hours
' from time of mail last sent.
If Now() - Bcell.Offset(0, 49) > 0.9875 Then
If Bcell.Offset(0, 25) = Empty Then
If DateDiff("d", Now(), Bcell.Offset(0, 13)) = 7 Then
iTo = Bcell.Offset(0, 15)
iSubject = Bcell & " Due"
iBody = "<font face=""Calibri"" size=""3"">" & "Dear all,<br/><br/>" & _
"<u>FR No. " & Bcell & "</u><br/><br/>" & "Please be reminded that " & Bcell & " will be due by <b><FONT COLOR=#ff0000>" & _
Bcell.Offset(0, 13) & "</font></b>." & _
" Kindly ensure that the FR is closed by the due date and provide the draft FR report with preliminary investigation (Section B & D filled) to Quality.<br/><br/>" _
& "Thank you<br/><br/>" & "Best Regards,<br/>" & "Quality Department<br/><br/>" _
& "company Pte Ltd.<br/>" & "</font>"
SendEmail
Bcell.Offset(0, 49) = Now()
End If
End If
End If
End If
iTo = Empty
iSubject = Empty
iBody = Empty
Next Bcell
End Sub
Private Sub SendEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = iTo
.CC = "email#email.com"
.BCC = ""
.Subject = iSubject
.HTMLBody = iBody
.Importance = ImportanceLevel
'You can add a file like this
'.Attachments.Add ("C:\test.txt")
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You have two ways to accomplish this depending on the type of button you want to use to run the macro:
a) If the button is a simply Shape (Insert > Shapes), you need to move the contents of Workbook_Open to a new sub within your Module1 (let's call it "trigger") and right-click the shape > Assign macro > "trigger".
Sub trigger()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If ws.Cells(1, 1).Value = "Feedback Report (FR) Log" Then CheckDates ws:=ws
End If
Next ws
End Sub
b) If the button is not a shape but a form button, you need to double-click it while on the design view and move the contents of "trigger" to its own click sub (CommandButton1_click()).
c) Finally, remember to remove the contents of Workbook_Open() sub.
What is the correct syntax for pausing a VBA until the user saves an excel attachment? In the VB below the user is prompted upon opening the workbook with a selection, if that selection is yes then another message box appears asking them to fill out a form and save. I am trying to pause the VB until save is clicked. However, I am getting many compile errors currently. The lines with a ** ** were added to try and accomplish thisThank you :).
VB
Private Sub Workbook_Open()
Dim WS As Worksheet, Rng As Range, c As Range
Dim OutApp As Object, OutMail As Object
Dim Msg As String, Addr As String, FName As String, i As Long
Dim obj As Object
**Dim MyDoc As Document**
Dim MyFileCopy As String
Dim intAnswer As Integer
'define path
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsx"
'open sheet
Sheets("Email").Activate
intAnswer = MsgBox("Are there any issues to report", vbYesNoCancel)
Select Case intAnswer
Case vbYes
Range("D2").Value = "x"
MsgBox ("Please select an issue and save"), vbExclamation
'create a separate sheet2 to mail out and pause VB
Sheets(2).Copy
Set wkb = ActiveWorkbook
With wkb
**Set MyDoc = Documents.Add
MyDoc.SaveAs "MyFileCopy.xlsx"
DoEvents
Do
Loop Until MyDoc.Saved
.Close True**
End With
Case vbCancel
Application.SendKeys "%{F11}", True
Case Else
Range("C2").Value = "x"
End Select
'create connection, check condition, send email
Set OutApp = CreateObject("Outlook.Application")
Set WS = ThisWorkbook.Sheets("Email")
With WS
Set Rng = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
For Each c In Rng
Msg = "For " & WS.Cells(2, 2) & Chr(14) & Chr(14)
For i = 3 To 4
If LCase(WS.Cells(2, i)) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c
.CC = ""
.BCC = ""
.Subject = "Daily Operational Safety Briefing"
.Body = Msg
If Range("D2").Value & Chr(14) = "x" Then .Attachments.Add MyFileCopy, 1
.Send
End With
Next c
Set OutMail = Nothing
Set OutApp = Nothing
'confirm message sent, clear sheet, and delete copy
MsgBox "The data has been emailed sucessfully.", vbInformation
Range("C2:D2").ClearContents
Kill MyFileCopy
'Exit and do not save
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End Sub
As mentioned in the subject of this post, I am attempting to send emails automatically by running a macro so that if cell J2 has the words "Send Reminder" in it, then the email address in cell K2 should be sent an email with the subject title in cell L2 and Body in Cell M. I have a list of emails ranging from cells K2:K59
Currently I have the following code:
Sub SendEm()
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "K").End(xlUp).Row
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = Range("L2").Value
.To = Range("K" & i).Value
.Body = Range("M2").Value
.Send
End With
Next i
MsgBox "E-mail successfully sent", 64
Application.DisplayAlerts = False
Set Mail_Object = Nothing
End Sub
I already have outlook open with references for Microsoft Outlook 14.0 Object Library selected amongst others, and I get an error saying " Run-time error '287' Application-definer or object-defined error, if i try to debug it, it highlights .Send in my code.
Can anyone help point out what I am doing wrong? I have tried various types of code to send emails based on different youtube videos etc. but seem to run into this error each time!
Thanks for your help ahead of time!
Edit1: I updated the code to the following based on suggestions and now a different issue:
Private Sub CommandButton21_Click()
'~~> Excel Objects/Variables
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Outlook Objects/Variables
Dim OutApp As Object
Dim OutMail As Object
Dim emailRange As Range, cl As Range
Dim sTo As String
Dim subjectRange As Range, c2 As Range
Dim sSubject As String
Dim bodyRange As Range, c3 As Range
Dim sBody As String
'~~> Set your worksheet here
Set ws = ThisWorkbook.Sheets("Sheet11")
'~~> Open Outlook
Set OutApp = CreateObject("Outlook.Application")
With ws
'~~> Get last row from Col J as that is what we
'~~> are going to check for the condition
lRow = .Range("J" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
If .Range("J" & i).Value = "Send Reminder" Then
'~~> Create new email
Set emailRange = Worksheets("Sheet11").Range("K2:K59")
For Each cl In emailRange
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
Set subjectRange = Worksheets("Sheet11").Range("L2:L59")
For Each c2 In subjectRange
sSubject = sSubject & ";" & c2.Value
Next
sSubject = Mid(sSubject, 2)
Set bodyRange = Worksheets("Sheet11").Range("M2:M59")
For Each c3 In bodyRange
sBody = sBody & ":" & c3.Value
Next
sBody = Mid(sBody, 2)
Set OutMail = OutApp.CreateItem(0)
'On Error Resume Next
With OutMail
'~~> Customize your email
.To = ""
.CC = sTo
.BCC = ""
.Subject = "typed subject1" & sSubject
.Body = ""
.Display '<~~ Change to .Send to actually send it
End With
End If
Next i
End With
End Sub
This code opens up multiple windows in outlook with all the emails listed in K2:K59. For example, if three cells in J2:J59 have send reminder, i open 3 email windows with all the emails listed in the cc box, instead of either multiple windows with individual emails or one window with all the emails. I think I have to close the loop somehow but am not certain how! Thanks for your help.
Mail_Object.CreateItem(o)
Shouldn't that be
Mail_Object.CreateItem(0)
0 and not o
In the below code, you are not required to set a reference to MS Outlook Object Library. I am using Late Binding with MS Outlook.
Try this (Untested)
I have commented the code so you shall not have a problem understanding the code but if you do then simply post back :)
Option Explicit
Sub Sample()
'~~> Excel Objects/Variables
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Outlook Objects/Variables
Dim OutApp As Object
Dim OutMail As Object
'~~> Set your worksheet here
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Open Outlook
Set OutApp = CreateObject("Outlook.Application")
With ws
'~~> Get last row from Col J as that is what we
'~~> are going to check for the condition
lRow = .Range("J" & .Rows.Count).End(xlUp).Row
'~~> Loop through the rows
For i = 2 To lRow
If .Range("J" & i).Value = "Send Reminder" Then
'~~> Create new email
Set OutMail = OutApp.CreateItem(0)
With OutMail
'~~> Customize your email
.To = ws.Range("K" & i).Value
.Subject = ws.Range("L" & i).Value
.Body = ws.Range("M" & i).Value
.Display '<~~ Change to .Send to actually send it
End With
End If
Next i
End With
End Sub
Since you have Outlook open you do not have to do anything complicated.
Set Mail_Object = GetObject(, "Outlook.Application")
I did something similar yesterday, here is the code I used, hope it helps you out.
Sub EmailCopy()
Dim oApp, oMail As Object, X As Long, MyBody As String
Application.ScreenUpdating = False
On Error Resume Next
Set oApp = CreateObject("Outlook.Application")
For X = 2 To Range("A" & Rows.Count).End(xlUp).Row
MyBody = Replace(Join(Application.Transpose(Range("E5:E" & Range("D" & Rows.Count).End(xlUp).Row - 1).Value), vbLf & vbLf), "<FirstName>", Range("B" & X).Text)
MyBody = MyBody & vbLf & vbLf & Join(Application.Transpose(Range("E" & Range("D" & Rows.Count).End(xlUp).Row & ":E" & Range("E" & Rows.Count).End(xlUp).Row)), vbLf)
Set oMail = oApp.CreateItem(0)
With oMail
.To = Range("A" & X).Text
.cc = Range("E1").Text
.Subject = Range("E2").Text
.Body = MyBody
.Attachments.Add Range("E3").Text
.Display
If UCase(Range("E4").Text) = "SEND" Then
.Send
ElseIf UCase(Range("E4").Text) = "DRAFT" Then
.Save
.Close False
Else
MsgBox "You need to choose Draft or Send in cell E4"
End
End If
End With
Application.ScreenUpdating = True
Set oMail = Nothing
Next
Set oApp = Nothing
End Sub
Recipients go in Column A and First Name goes in column B, Any CC's go in E1, Subject goes in E2, Any attachment links go in E3, E4 is either Draft or Send to create a draft or do a send.
Then the message body goes in E5 down as far as you want, each line will be separated by a double return. Anywhere you use FirstName wrapped in greater than and less than signs the code will replace it with the person's First Name from column B.
Straight after that put the signature you want and put "Signature" in column D next to the start of it, this will be separated by single returns.