Send one email with all cell values

Question

In my Excel table, I have a column that will populate cell values if it meets my criteria.
My code goes through each of the rows in that column, and if a cell has a value it will populate a single email for each row to send automatically.

I would like the code to figure out all the rows that are not blank, and send only one email with the subject or body of the email showing the cell's value from first to last. I would like the subject line to be first cell value to last cell value.

Sub Email()

    Dim OL As Outlook.Application, Appoint As Outlook.AppointmentItem, ES As Worksheet, _
    r As Long, i As Long, WB As ThisWorkbook, j As Long, k As Long

    Set WB = ThisWorkbook
    Set ES = WB.Sheets("Automatic Email Reminder")
    r = ES.Cells(Rows.Count, 1).End(xlUp).Row
    k = ES.Cells(Rows.Count, 1).End(xlUp).Row
    Set OL = New Outlook.Application

    For i = 4 To r
        If ES.Cells(i, 6) = "" Then 'change this (5 for M&C, 6 for CP, 7 for Objection)

        Else
            Set Appoint = OL.CreateItem(olAppointmentItem)
            With Appoint
                .Subject = ES.Cells(i, 6).Value  
                .RequiredAttendees = "example@email.com"
                .Start = ES.Cells(i, 8).Value
                .Duration = 5
                .ReminderMinutesBeforeStart = 2880
                .Body = ES.Cells(i, 6).Value 
                .MeetingStatus = olMeeting
                .Send
            End With
        End If
    Next i
    Set OL = Nothing

End Sub

Answer 1

You need to create an appointment body string in the loop after which you could send a meeting request, for example:

Dim apptBody as String 
For i = 4 To r
    apptBody = apptBody & ES.Cells(i, 6).Value
Next i

Set Appoint = OL.CreateItem(olAppointmentItem)
With Appoint
 .Subject = ES.Cells(i, 6).Value  
 .RequiredAttendees = "example@email.com"
 .Start = ES.Cells(i, 8).Value
 .Duration = 5
 .ReminderMinutesBeforeStart = 2880
 .Body = apptBody 
 .MeetingStatus = olMeeting
 .Send
End With