Email people based on a range VBA - excel

Question

I have the following data set
I have the following code to send an email to each row. How do I make it group the rows and send them all as 1 email like in the picture
Here is an example of the email I am looking to build
At the moment the code steps through each row and builds and email off of that. I want it to check the A Column for a code and find all other columns with the same code and build one email using information from all of their columns
Sub SendIntransitEmail()
Dim Mail_Object, OutApp As Variant
Dim eRng1, eRng2, eRng3, rng1, rng2, rng3, rng4, cl As Range
Dim sTo, sCC, sLoc, sFile1, sFile2, sHeader, sBody As String
Set rng4 = ThisWorkbook.Worksheets("sheet1").Range("B4")
Dim intNum As Integer
intNum = ThisWorkbook.Worksheets("sheet1").Range("B1")
For i = 5 To intNum
On Error Resume Next
Set Mail_Object = CreateObject("Outlook.Application")
Set OutApp = Mail_Object.CreateItem(0)
Set rng1 = ThisWorkbook.Worksheets("sheet1").Range("A" & i)
Set eRng1 = ThisWorkbook.Worksheets("sheet1").Range(Cells(i, 5), Cells(i, 8))
Set eRng2 = ThisWorkbook.Worksheets("sheet1").Range(Cells(i, 9), Cells(i, 40))
Set eRng3 = ThisWorkbook.Worksheets("sheet1").Range(Cells(4, 2), Cells(4, 4))
Set eRng4 = ThisWorkbook.Worksheets("sheet1").Range(Cells(i, 2), Cells(d, 2))
For Each cl In eRng1
sTo = sTo & ";" & cl.Value
Next
sTo = Mid(sTo, 2)
For Each cl In eRng2
sCC = sCC & ";" & cl.Value
Next
For Each cl In eRng3
sDelivery = sDelivery & cl.Value
Next
For Each cl In eRng4
sTrailer = sTrailer & cl.Value
Next
For Each cl In eRng5
sShipper = sShipper & cl.Value
Next
sCC = Mid(sCC, 2)
Set OApp = CreateObject("Outlook.Application")
Set OMail = OApp.CreateItem(0)
With OutApp
.To = sTo
.CC = sCC
.Subject = "Location " & rng1
.BodyFormat = olFormatHTML
.HTMLBody = "<p> Hello, </p><p>Your delivery information is below: </p><p>
Deliver Number: " & sDelivery & "<p/> <p> Trailer Number: " & sTrailer & "
<p/><p>Shipper ID: " & sShipper & "<p/><p>Best Regards </p>"
.display
End With
Set OMail = Nothing
Set OApp = Nothing
Set eRng1 = Nothing
Set eRng2 = Nothing
sTo = ""
sCC = ""
Next i
End Sub

Answer 1

I see what you're trying to do now. You should shift your loop from running on each column, to rather doing by row. Something like... if row doesn't have member above, collect all appropriate members in the row's column, then run a loop through remaining rows, testing to see if they MATCH and then appending them to the email.
At the moment, I'm too lazy to write this out but here's a custom formula that might help you that will only test if the member in the respective row exists above.
Sub SendIntransitEmail()
Dim Mail_Object, OutApp As Variant
Dim eRng1, eRng2, eRng3, rng1, rng2, rng3, rng4, cl As Range
Dim sTo, sCC, sLoc, sFile1, sFile2, sHeader, sBody As String
Set rng4 = ThisWorkbook.Worksheets("sheet1").Range("B4")
Dim intNum As Integer
intNum = ThisWorkbook.Worksheets("sheet1").Range("B1")
Set Mail_Object = CreateObject("Outlook.Application")
For i = 5 To intNum
On Error Resume Next 'I wouldn't use this...
'test if first instance of plant
If New_Plant_Test(ThisWorkbook.Worksheets("sheet1").Cells(i, 1)) = True Then
'run a loop from this row all the way down to populate the respective emails,
'example:
For Each rcell In Range(ThisWorkbook.Worksheets("sheet1").Cells(i, 1), ThisWorkbook.Worksheets("sheet1").Cells(intNum, 1)).Cells
'apply respective values to variables in that row.
'this should probably be a separate private macro.
Next rcell
'send email and clear variables and clear variables
Else
'skips as plant already existed
End If
Next i 'continue loop by each row
End Sub
Private Function New_Plant_Test(rng As Range) As Boolean
Dim tRow As Long, ws As Worksheet
tRow = rng.Row
Set ws = Sheets(rng.Parent.Name)
On Error GoTo NewMember
tRow = Application.WorksheetFunction.Match(ws.Cells(tRow, 1), Range(ws.Cells(1, 1), ws.Cells(tRow - 1, 1)), False)
On Error GoTo 0
Exit Function
NewMember:
New_Plant_Test = True
End Function