Pull Data By Vendor from Excel for Outlook Email

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 = "[email protected]"
            .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

Solution

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