I have a list of vendors that I sort by name and then have a macro go through and pull out data pieces from fields and place them inside an Outlook email. Pretty straightforward until I get to vendors with multiple lines, as I then need to have the code know to look at all the lines for that vendor and pull their info and place it into a list in the email (so they do not get multiple emails all at once).
The above image is a sample of the list after I have sorted it by vendor. So I would want one email for each vendor, but vendor1 would need the data from Invoice, Paid Amt, Check ID, and Check Dt for both of his lines. Vendor 2 would just have one line, and Vendor3 would have 3. I need a way to have the macro know to look at the vendor name (or Vendor #) and know that it needs to pull the data from the next line and include it in that same email until it is at the next vendor.
I am not a programmer and am trying to make this work. Below is an example of what I have been trying so far but it only creates one email for every line. Hoping someone smarter than me can help me. Thanks.
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim strDir As String
Dim strFilename As String
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strName1 As String
Dim strDept As String
Dim strName2 As String
Dim lr As Long
Dim oItem As Object
Dim dteSat As Date
Dim nextSat As Date
Dim lastRow As Long
Dim ws As String
'Link to Outlook, use GetBoiler function to pull email signature
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
sigString = Environ("appdata") & _
"\Microsoft\Signatures\Uncashed Checks.htm"
If Dir(sigString) <> "" Then
signature = GetBoiler(sigString)
Else
signature = ""
End If
Select Case Time
Case 0.25 To 0.5
GreetTime = "Good morning"
Case 0.5 To 0.71
GreetTime = "Good afternoon"
Case Else
GreetTime = "Good evening"
End Select
'Define the date for the next Saturday
With Item
K = Weekday(TODAY)
dteChk = Weekday(TODAY) - 30
dteSat = Now() + (10 - K)
nextSat = Date + 7 - Weekday(Date, vfSaturday)
End With
'Select the currently active sheet and insert a column next to column I, then fill it with the word 'yes'. The yes values will act as triggers to tell the code to run for that row.
'Delete first 7 rows of report. Find the Paid Amt header and then replace that column with a re-formatted one that shows the full numbers with decimals and zeroes. Change column E
'to UPPER case using the index and upper functions.
lr = ActiveSheet.UsedRange.Rows.Count
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
Rows("1:7").Select
Columns("C").SpecialCells(xlBlanks).EntireRow.Delete
Columns("I:I").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set rng9 = ActiveSheet.Range(rng8, ActiveSheet.Cells(Rows.Count, rng8.Column).End(xlUp).Address)
rng9.Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.FormulaR1C1 = "=TEXT(RC[+1],""#.00"")"
ActiveCell.Copy
Range(ActiveCell.Offset(350 - ActiveCell.Row, 0), ActiveCell.Offset(1, 0)).Select
ActiveSheet.Paste
ActiveCell.Offset.Resize(1).EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Offset(0, 1).Select
ActiveCell.Offset.Resize(1).EntireColumn.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToRight
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
[e2:e350] = [INDEX(UPPER(e2:e350),)]
'Begin a loop that looks at all the yes values in column I and then begins to create emails. Define the columns to be used for data by looking for the header names such as Paid Amt.
For Each cell In Columns("G").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "I").Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)
Set rng8 = Range("A1:Z1").Find("Paid Amt")
Set foundCell = Cells(cell.Row, rng8.Column)
Set rng9 = Range("A1:AG1").Find("Check Dt")
Set foundCell1 = Cells(cell.Row, rng9.Column)
Set rng12 = Range("A1:AG1").Find("Student Perm Address")
Set foundcell2 = Cells(cell.Row, rng12.Column)
'Create the actual email data, definiing the body and recipients/names, etc, based on the values in the cells noted below. Sentonbehalf is the 'From' field. Change font color
'using the hexadecimal codes. The one used here 1F497D is Blue-Gray.
With OutMail
strname = Cells(cell.Row, "A").Value
strName2 = Trim(Split(strname, ",")(1))
strName3 = Cells(cell.Row, "R").Value
strName4 = Cells(cell.Row, "E").Value
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because you have an uncashed check that was sent to you over 30 days ago. " & _
"Please cash or deposit your check.<br><br>" & _
"<B>The amount of the check is $" & foundCell & " and is dated " & foundCell1 & ". The check was mailed to the following address: <br><br>" & _
"<ul>" & foundcell2 & "<br></B></ul>"
.SentOnBehalfOfName = "accounts-payable#salemstate.edu"
.To = cell.Value
.Subject = "Uncashed Check from Salem State University"
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B>" & "Important Information Regarding Your Student Account </B><br><br><p style=font-size:18.5px> Dear " & strName2 & ", " & strbody & "<br>" & signature & "<HTML><BODY><IMG src='C:\Users\gmorris\Pictures\Saved Pictures\220px-Salem_State_University_logo.png' /></BODY></HTML>"
.display 'Or use Send
End With
Set OutMail = Nothing
End If
Next cell
End Sub
If the email addresses are sorted:
When the email address matches the previous:
Bypass creating email, append to the body.
When there is a new email address:
Send the existing mail before creating new email.
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
For i = 2 To lr
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = toAddress
.Subject = "Uncashed Check from Salem State University"
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strVoucher = Cells(i, "D").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher & "<br>"
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub
Related
#Niton solved my first question for me, which was how to pull in data from an Excel file in a way that would loop through until a new email address was found. It allows me to take data from multiple lines (and a couple fields on those lines) and place it into an Outlook email.
My problem now is that when it does so, I need it to be included in the body of an email. So there would be some text such as a greeting, then 'you have these vouchers that we need paid off, please...EXCEL DATA HERE...Thank you for looking at this, here is the address you can send to, and if you need to update us, email us back'. That wording is not complete and will be changed, but that is the general idea...getting the Excel text into the body of the email. I have added some fields that are pulled to the strVoucher as shown in the code.
I have tried different iterations as at first the Excel info would just repeat along with the text over and over. I then was able to separate at least part of the email code so that it would put in the first greeting piece of text, but then I am stuck in trying to get it to add more text after the Excel data without repeating all the text over and over. I tried to add another 'With Outmail' section after the strVoucher piece is added, but that just overrode the whole email.
Here is my code as it stands now. Thanks #niton!
Option Explicit
Sub oneEmail_SortedEmailAddresses()
Dim OutApp As Object
Dim OutMail As Object
Dim strVoucher As String
Dim lr As Long
Set OutApp = CreateObject("Outlook.Application")
lr = ActiveSheet.UsedRange.Rows.Count
Dim toAddress As String
Dim i As Long
Dim refundDescYes As Boolean
Dim sigString As String
Dim strbody As String
Dim strname As String
Dim strname2 As String
Dim strCheckNbr As String
Dim strCheckDate As String
Dim strCheckAmt As String
Dim strCheckTst As String
Rows("1:6").Select
Selection.Delete
Range("A1:N1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort. _
SortFields.Clear
ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort. _
SortFields.Add2 key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Check Reconciliation Status").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("i2") = "Yes"
Range("I2").AutoFill Destination:=Range("I2:I" & lr)
For i = 2 To lr
Set OutApp = CreateObject("Outlook.Application")
'sigString = Environ("appdata") &
'"\Microsoft\Signatures\Uncashed Checks.htm"
' If Dir(sigString) <> "" Then
' signature = GetBoiler(sigString)
' Else
' signature = ""
' End If
' Select Case Time
' Case 0.25 To 0.5
' GreetTime = "Good morning"
' Case 0.5 To 0.71
' GreetTime = "Good afternoon"
' Case Else
' GreetTime = "Good evening"
' End Select
' Email address
If ActiveSheet.Range("N" & i).Value <> "" Then
' One email per email address
' This assumes the addresses are sorted
If ActiveSheet.Range("N" & i).Value <> toAddress Then
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
toAddress = ActiveSheet.Range("N" & i).Value
Debug.Print toAddress
Set OutMail = Nothing
refundDescYes = False
Set OutMail = OutApp.CreateItem(0)
With OutMail
strname = Cells(i, "A").Value
strname2 = strname
If InStr(Cells(i, "A"), ",") Then strname2 = Trim(Split(strname, ",")(1))
.To = toAddress
.Subject = "Open Vouchers"
strbody = "<Font face = TimesNewRoman p style=font-size:18.5px color = #0033CC)<br><br>You are receiving this email because our records show you have vouchers open as follows: " & _
"<br><br>Voucher #: " & strVoucher & _
"<br>Check Date: " & strCheckDate & _
"<br>Check Amount: " & strCheckAmt
.HTMLBody = "<Font face = TimesNewRoman p style=font-size:26.5px color = #0033CC><B><p style=font-size:18.5px>Dear " & strname2 & ", " & strbody & "<br>"
.HTMLBody = "<B><br><br>Please reply to this email with any questions." & _
"<br><br>***If we do not receive a reply from you within the next 30 days, you will not be paid."
End With
End If
' Refund Desc
If ActiveSheet.Range("I" & i).Value = "Yes" Then
refundDescYes = True
' Voucher
strCheckTst = "Check Number "
strCheckNbr = Cells(i, "K").Value
strVoucher = strCheckTst & Cells(i, "D").Value & " " & Cells(i, "K").Value
strCheckDate = Cells(i, "L").Value
strCheckAmt = Cells(i, "H").Value
With OutMail
.HTMLBody = .HTMLBody & "<br>" & strVoucher
End With
End If
End If
Next
If Not OutMail Is Nothing Then
If refundDescYes = True Then
OutMail.display
Else
OutMail.Close 1 ' olDiscard
End If
End If
Set OutMail = Nothing
Debug.Print "Done."
End Sub
This example below probably will not work because you didn't post a copy of your data on the worksheet, so I had to make some assumptions. Use this as an example of how to organize your code.
Your main issue is the organization of your code, both inside and outside your loop. In my example, I've simplified the main logic by pulling big blocks of code out into other routines. This should make the overall "flow" of your code easier to read and work with.
Notice a couple things:
Always fully qualify your references to ranges, worksheets, and workbooks.
Avoid magic numbers
Rework the code below into your own data and see if it helps.
EDIT: to send only one email per vendor
Option Explicit
Const NAME_COL As Long = 1
Const VOUCHER_COL As Long = 4
Const DATE_COL As Long = 12
Const CHKNUM_COL As Long = 11
Const AMT_COL As Long = 8
Const TOADDR_COL As Long = 14
Sub Example()
Dim statusWS As Worksheet
Set statusWS = ThisWorkbook.Sheets("Check Reconciliation Status")
' PrepareData statusWS
'--- only do this once
Dim outlookApp As Outlook.Application
Set outlookApp = AttachToOutlookApplication
Dim addresses As Dictionary
Set addresses = GetEmailAddresses(statusWS)
Dim emailAddr As Variant
For Each emailAddr In addresses
'--- create the email now that everything is ready
Dim email As Outlook.MailItem
Set email = outlookApp.CreateItem(olMailItem)
With email
.To = emailAddr
.Subject = "Open Vouchers"
.HTMLBody = BuildEmailBody(statusWS, addresses(emailAddr))
'--- send it now
' (if you want to send it later, you have to
' keep track of all the emails you create)
'.Send
End With
Next emailAddr
End Sub
Sub PrepareData(ByRef ws As Worksheet)
With ws
.Rows("1:6").Delete
.Range("A1:N1").AutoFilter
.AutoFilter.Sort.SortFields.Clear
.AutoFilter.Sort.SortFields.Add2 Key:=Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortTextAsNumbers
With .AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'.Rows("2:5").Delete Shift:=xlUp
.Range("i2") = "Yes"
'--- it only makes sense to find the last row after all the
' other prep and deletions are complete
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("I2").AutoFill Destination:=Range("I2:I" & lastRow)
End With
End Sub
Function GetEmailAddresses(ByRef ws As Worksheet) As Dictionary
Dim addrs As Dictionary
Set addrs = New Dictionary
With ws
Dim lastRow As Long
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
'--- each entry in the dictionary is keyed by the email address
' and the item value is a CSV list of row numbers
Dim i As Long
For i = 2 To lastRow
Dim toAddr As String
toAddr = .Cells(i, TOADDR_COL).Value
If addrs.Exists(toAddr) Then
Dim theRows As String
theRows = addrs(toAddr)
addrs(toAddr) = addrs(toAddr) & "," & CStr(i)
Else
addrs.Add toAddr, CStr(i)
End If
Next i
End With
Set GetEmailAddresses = addrs
End Function
Function BuildEmailBody(ByRef ws As Worksheet, _
ByRef rowNumbers As String) As String
Const body1 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
"#0033CC)"
Const body2 As String = "<Font face = TimesNewRoman p style=font-size:18.5px color = " & _
"#0033CC)<br><br>You are receiving this email because our " & _
"records show you have vouchers open as follows: "
Const body3 As String = "<B><br><br>Please reply to this email with any questions." & _
"<br><br>***If we do not receive a reply from you within " & _
"the next 30 days, you will not be paid.<br><br>"
With ws
Dim rowNum As Variant
rowNum = Split(rowNumbers, ",")
Dim body As String
body = body1 & TimeOfDayGreeting & .Cells(rowNum(LBound(rowNum)), NAME_COL) & "," & body2
Dim i As Long
For i = LBound(rowNum) To UBound(rowNum)
body = body & "<br><br>Voucher #: " & .Cells(rowNum(i), VOUCHER_COL)
body = body & "<br>Check Date: " & Format(.Cells(rowNum(i), DATE_COL), "dd-mmm-yyyy")
body = body & "<br>Check Amount: " & Format(.Cells(rowNum(i), AMT_COL), "$#,##0.00")
Next i
End With
body = body & body3 & EmailSignature
BuildEmailBody = body
End Function
Function EmailSignature() As String
' Dim sigCheck As String
' sigCheck = Environ("appdata") & "\Microsoft\Signatures\Uncashed Checks.htm"
'
' If Dir(sigCheck) <> vbNullString Then
' EmailSignature = GetBoiler(sigString)
' Else
EmailSignature = vbNullString
' End If
End Function
Function TimeOfDayGreeting() As String
Select Case Time
Case 0.25 To 0.5
TimeOfDayGreeting = "Good morning "
Case 0.5 To 0.71
TimeOfDayGreeting = "Good afternoon "
Case Else
TimeOfDayGreeting = "Good evening "
End Select
End Function
Public Function OutlookIsRunning() As Boolean
'--- quick check to see if an instance of Outlook is running
Dim msApp As Object
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
'--- not running
OutlookIsRunning = False
Else
'--- running
OutlookIsRunning = True
End If
End Function
Public Function AttachToOutlookApplication() As Outlook.Application
'--- finds an existing and running instance of Outlook, or starts
' the application if one is not already running
Dim msApp As Outlook.Application
On Error Resume Next
Set msApp = GetObject(, "Outlook.Application")
If Err > 0 Then
'--- we have to start one
' an exception will be raised if the application is not installed
Set msApp = CreateObject("Outlook.Application")
End If
Set AttachToOutlookApplication = msApp
End Function
I have three columns: A) Enterprises B) Email address matching the enterprise C) Yes or No
If there is a YES in column C, I want to send a message to the email address in column B.
This is what I have. Nothing is happening.
Sub Test2()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*#?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "yes" _
And LCase(Cells(cell.Row, "D").Value) <> "send" Then
Set OutMail = OutApp.CreateItem(olMailItem)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date."
Attachments.Add ("\\C:\test.pdf")
.Send '
End With
On Error GoTo 0
Cells(cell.Row, "D").Value = "send"
Set OutMail = Nothing
End If
Next cell
cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub
The code below will loop through Row 2 to the last row in the UsedRange and make sure that Columns A, B & C are not empty as well as check to make sure Column D is empty, which the code uses as a flag to show whether the email has previously been sent.
I've added a Regex validation function to the code to validate the email address.
Sub LoopThroughRange_SendEmail()
Dim OutApp As Object: Set OutApp = CreateObject("Outlook.Application")
Dim OutMail As Object: Set OutMail = OutApp.CreateItem(0)
Dim oRegEx As Object
Set oRegEx = CreateObject("VBScript.RegExp")
Dim i As Long
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
'declare and set the worksheet you are working with
For i = 2 To ws.UsedRange.Rows.Count
'loop from Row 2 To Last Row in UsedRange
If ws.Cells(i, "A").Value <> "" And ws.Cells(i, "B").Value <> "" And ws.Cells(i, "C").Value = "Yes" And ws.Cells(i, "D").Value = "" Then
' make sure that Columns A, B & C are not empty and D is empty (which we will use as a flag to show that the email did get sent.
If ValidEmail(ws.Cells(i, "B").Value, oRegEx) Then
With OutMail
.To = ws.Cells(i, "B").Value
.CC = ""
.BCC = ""
.Subject = "Reminder"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please contact us to discuss bringing " & _
"your account up to date."
.Attachments.Add ("\\C:\test.pdf")
.Display '.Send
End With
ws.Cells(i, "D").Value = "Sent # " & Format(Now(), "yyyy-MM-dd hh:mm:ss")
Else
ws.Cells(i, "D").Value = "Email not valid"
End If
End If
End Sub
Public Function ValidEmail(pAddress As String, ByRef oRegEx As Object) As Boolean
With oRegEx
.Pattern = "^(([a-zA-Z0-9_\-\.\']+)#((\[[0-9]{1,3}\.[0-9]{1,3}\.[0-9]{1,3}\.)|(([a-zA-Z0-9\-]+\.)+))([a-zA-Z]{2,4}|[0-9]{1,3})(\]?)(\s*;\s*|\s*$))+$" 'pattern for multiple email addresses included
ValidEmail = .test(pAddress)
End With
End Function
I have an Excel spreadsheet which contains information about equipment on loan: name, email address, description, hyperlink to the loan document, date of loan, etc.
I have VBA code which runs through the sheet, checking for loan date, and if the return date is within 7 days of return, automatically emails the 'loanee' with the details pulled from the sheet.
Once an email is sent, it then updates the sheet with details of when the email was sent. All is working, apart from the hyperlink to their document.
All I get is the text from the cell.
Private Sub Workbook_Open()
Worksheets("Tracker").Select
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim sSendCC As String
Dim sSubject As String
Dim sTemp As String
Dim strBody As String
Dim Sigstring As String
Dim Signature As String
Dim sURL As String
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
sSendCC = Range("D3").Value
sSubject = "You are within 7 days of the deadline"
Sigstring = Environ("appdata") & _
"\Microsoft\Signatures\Mike.htm"
If Dir(Sigstring) <> "" Then
Signature = GetBoiler(Sigstring)
Else
Signature = ""
End If
lLastRow = Cells(Rows.Count, 5).End(xlUp).Row
For lRow = 7 To lLastRow
sURL = Cells(lRow, 5).Value
If Not IsEmpty(Cells(lRow, 3)) Then
If Cells(lRow, 8) <> "YES" Then
If Cells(lRow, 7) <= Now() + 7 Then
Set OutMail = OutApp.CreateItem(0)
strBody = "Hello " & Cells(lRow, 2) & "," & "<br><br>" & _
"You have previously signed the loan of equipment from my department." & "<br><br>" & _
"You are within 7 days of the agreement validity and are required to take action to amend." & "<br><br>" & _
"Description of loan: " & Cells(lRow, 4).Value & "<br><br>" & _
"Hyperlink: " & Cells(lRow, 5) & "<br><br>" & _
"Please return the item/s or renew the loan agreement (at the above hyperlink) at your earliest convenience.<br><br>"
With OutMail
.Display
End With
On Error Resume Next
With OutMail
.To = Cells(lRow, 3)
If sSendCC > "" Then .CC = sSendCC
.Subject = sSubject
.HTMLBody = "<html><body>" & strBody & Signature
SendKeys ("^{ENTER}")
End With
Set OutMail = Nothing
Cells(lRow, 8) = "YES"
Cells(lRow, 9) = "E-mail sent on: " & Now()
End If
End If
End If
Next lRow
Set OutApp = Nothing
End Sub
You need to add a [Some_Hyperlink_Text] tag in your code.
try this modified bit of your code
sURL = Cells(lRow),5).Hyperlinks(1).Address
strBody = "Hello " & Cells(lRow, 2) & "," & "<br><br>" & _
"You have previously signed the loan of equipment from my department." & "<br><br>" & _
"You are within 7 days of the agreement validity and are required to take action to amend." & "<br><br>" & _
"Description of loan: " & Cells(lRow, 4).Value & "<br><br>" & _
"Hyperlink: 'Insert Hyperlink Text Here'<br><br>" & _
"Please return the item/s or renew the loan agreement (at the above hyperlink) at your earliest convenience.<br><br>"
In the above code that I have modified, I am assuming that Cells(lRow, 5).value (sURL variable) is a URL (not a in worksheet hyperlink). If it is a worksheet hyperlink, then you might need to extract the link.
So, I was helped with this code from Ron de Bruin from user Vityata but I am having trouble getting the macro to STOP running once it runs out of WO's and emails. If I put ' stop ' in after .send I have to click run over and over until all the emails are sent and everything is marked as 'sent', and then on the last one it won't stop running until I hit escape. I want to find a way to make the code stop running once there are no more work orders (paired with emails that haven't been sent yet) left to email out. If there is a way to also note the read receipt in a column of the 2018 worksheet that would be extremely helpful but I've been struggling. I am used to creating forms in VBA, so information going OUT has always been difficult for me to automate.
The original post is here Original post
Sub test2()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
For Each cell In Worksheets("2018").Columns("T").Cells
Set OutMail = OutApp.CreateItem(0)
If cell.Value Like "?*#?*.?*" Then 'try with less conditions first
With OutMail
.To = Cells(cell.Row, "T").Value
.Subject = "Work Order: " & Cells(cell.Row, "G").Value & " assigned"
.Body = "Work Order: " & Cells(cell.Row, "G").Value & _
" has been assigned to you." & _
vbNewLine & vbNewLine & _
"Region: " & Cells(cell.Row, "B").Value & vbNewLine & _
"District: " & Cells(cell.Row, "C").Value & vbNewLine & _
"City: " & Cells(cell.Row, "D").Value & vbNewLine & _
"Atlas: " & Cells(cell.Row, "E").Value & vbNewLine & _
"Notification Number: " & Cells(cell.Row, "F").Value & vbNewLine
.ReadReceiptRequested = True
.OriginatorDeliveryReportRequested = True
.Send
End With
Cells(cell.Row, "V").Value = "sent"
Set OutMail = Nothing
End If
Next cell
'Set OutApp = Nothing 'it will be Nothing after End Sub
Application.ScreenUpdating = True
End Sub
EDIT:
I tried to use the Do Loop function with no luck
The issue is that you run through all cells in column T, because the range Worksheets("2018").Columns("T").Cells contains the complete column.
Add the following code at the beginning of your sub
Dim lastRow As Long
Dim ws As Worksheet
Dim rg As Range
Set ws = Worksheets("2018")
With ws
lastRow = .Cells(Rows.Count, "T").End(xlUp).Row
Set rg = Range(.Cells(1, "T"), .Cells(lastRow, "T"))
End With
And change the for loop to
For Each cell In rg
rg only contains the filled cells of column T. In this way the code only runs through the cells which contain data.
PS Based on the information in the comment you would need to code your condition like that
If cell.Value Like "?*#?*.?*" And UCASE(cell.Offset(0, 1).Value) <> "SENT" Then
If I change c.Offset(, 1) to c.Offset(, 0) an email will get sent to the first recipient but not the next. If I change c.Offset(, 0) to c.Offset(, 1) I get outlook does not recognize one or more names. How can I get the syntax correct to send the email to multiple users? The design of the spreadsheet is below as well as the VB. I apologize for the lengthy message, just trying to be complete. Thank you :).
Design of spreadsheet
A B C D
Email Date Comment 1 Comment 2
123#gmail.com
456#hotmail.com
when the spreadsheet opens the below runs automatically:
VB
Private Sub Workbook_Open()
Dim sR As String
Dim sFile As String
Sheets("Email").Activate
Range("A1").Select
If MsgBox("Are there any issues to report", vbYesNoCancel) = vbYes Then
Range("D2").Value = "x"
MsgBox ("Please select an issue and save"), vbExclamation
Else
Range("C2").Value = "x"
If vbCancel Then Application.SendKeys "%{F11}", True
'define path
MyFileCopy = "L:\NGS\HLA LAB\total quality management\QC & QA\DOSE reports\DOSE reporting form Attachment.xlsx"
'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(c.Row, i)) = "x" Then
Msg = Msg & " -" & WS.Cells(1, i) & Chr(14)
End If
Next
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = c.Offset(, 1)
.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
'confirm message sent, clear sheet, and delete copy
MsgBox "The data has been emailed sucessfully.", vbInformation
Range("C2:D2").ClearContents
Kill MyFileCopy
Set OutMail = Nothing
Set OutApp = Nothing
'Exit and do not save
Application.Quit
ThisWorkbook.Close SaveChanges:=False
End If
End Sub
All you need is .To = c because your sent is sent to column A, which has the addresses.
There is no need to offset the c cell in the range at all.
If you wish to send an email to more than one address, semi-colons need to be between each address, as this is how Outlook resolves that there is more than one address.
So, based on your example above:
.To = c & ";" & c.Offset(1) ' & ";" c.Offset(2) to carry it further.
Note that I also Offset c by 1 Row. You wrote c.Offset(,1) meaning it will offset 1 column. The arguments for Offset are Offset(rows,columns,[row height],[column width])