Insert Looped Text Pulled from Excel into Email Body

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:

1. Always fully qualify your references to ranges, worksheets, and workbooks.
2. 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