Email people based on a range VBA

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