Insert Looped Text Pulled from Excel into Email Body - excel

Question

#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

Answer 1

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