Send all due dates and names in one email

I have working code I found on the net.

When there is more than one due date in the column it will send email each time instead of sending all due dates and names in one email.

Names in column A, Expiry Date in column E, and email stamp as sent in Column F.

Private Sub Workbook_Open()
    Dim Email As String, Subj As String, Msg As String, wBox As String
    Dim RowNo As Long, i As Long, ky As Variant, cad As Variant
    Dim wsEmail As Worksheet, OutApp As Object, OutMail As Object, dic As Object
    Set wsEmail = ThisWorkbook.Sheets("Tracker")
    Set dic = CreateObject("scripting.dictionary")
    With wsEmail
        For RowNo = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If .Cells(RowNo, "E") <> "" Then
                If .Cells(RowNo, "F") = "" And .Cells(RowNo, "E") <> "" And .Cells(RowNo, "E") <= Date + 60 Then
                    If dic.exists(.Cells(RowNo, "F").Value) Then
          dic(.Cells(RowNo, "A").Value) = dic(.Cells(RowNo, "A").Value) & RowNo & "|"
                    Else
                        dic(.Cells(RowNo, "A").Value) = RowNo & "|"
                    End If
                End If
            End If
        Next
        For Each ky In dic.keys
            cad = Left(dic(ky), Len(dic(ky)) - 1)
            cad = Split(cad, "|")
            wBox = ""
            dBox = ""
            For i = 0 To UBound(cad)
                wBox = wBox & " " & wsEmail.Cells(cad(i), "A")
                dBox = wsEmail.Cells(cad(i), "E")
                .Cells(cad(i), "F") = "Sent"
                .Cells(cad(i), "G") = Environ("username")
                .Cells(cad(i), "H") = "E-mail sent on: " & Now()
            Next
            On Error Resume Next
            Set OutApp = GetObject("Outlook.Application")
            On Error GoTo 0
            If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
            Do: Loop Until Not OutApp Is Nothing
            Set OutMail = OutApp.CreateItem(0)
            
            With OutMail
                Subj = wBox & Space(1) & "from will expire soon"
                Msg = "Hi" & vbCrLf & vbCrLf _
                  & "This is an automated e-mail to let you know that" & wBox & Space(1) & " will expire as follow;" & vbCrLf & vbCrLf _
                  & "Expiry date:" & dBox & vbCrLf & vbCrLf & "Many Thanks " & vbCrLf _
                  & vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
                .To = "Sent to"
                .CC = ""
                .BCC = ""
                .Subject = Subj
                .ReadReceiptRequested = False
                .Body = Msg
                .Display
            End With
            mystring = ("Email has been sent for below staff;") & _
              vbCrLf & vbCrLf & ky
            MsgBox mystring
                
            Set OutApp = Nothing
            Set OutMail = Nothing
        Next
    End With
End Sub

This should get you started.

Read the code's comments and adjust it to fit your needs.

Private Sub SendEmails()

    Dim trackerSheet As Worksheet
    Set trackerSheet = ThisWorkbook.Worksheets("CTCTracker")
    
    Dim lastRow As Long
    lastRow = trackerSheet.Cells(trackerSheet.Rows.Count, "A").End(xlUp).Row
    
    Dim trackerRange As Range
    Set trackerRange = trackerSheet.Range("A5:A" & lastRow)
    
    ' Declare boolean to check if there are any expiring names
    Dim anyExpiring As Boolean
    
    Dim nameCell As Range
    For Each nameCell In trackerRange
        
        ' Check: 1) There is a expiring date
        '        2) Email not sent yet
        '        3) Expiring date less than today + 60 días

        If nameCell.Offset(0, 4).Value <> "" And _
            nameCell.Offset(0, 5).Value = "" And _
            nameCell.Offset(0, 4).Value <= Date + 60 Then
        
            ' Store names and expiring dates into array
            Dim infoArray() As Variant
            Dim counter As Long
            ReDim Preserve infoArray(counter)
            
            infoArray(counter) = Array(nameCell.Value, nameCell.Offset(0, 4).Value)
            counter = counter + 1
            
            ' Stamp action log
            nameCell.Offset(0, 5).Value = "Sent"
            nameCell.Offset(0, 6).Value = Environ$("username")
            nameCell.Offset(0, 7).Value = "E-mail sent on: " & Now()
            
            ' To be able to check later
            anyExpiring = True
            
        End If
    
    Next nameCell
    
    ' Exit if there are not expiring contacts
    If Not anyExpiring Then
        MsgBox "There are not expiring contacts"
        Exit Sub
    End If
    
    
    ' Prepare message
    Dim namesList As String
    For counter = 0 To UBound(infoArray)
        namesList = namesList & infoArray(counter)(0) & vbTab & vbTab & " | " & vbTab & vbTab & infoArray(counter)(1) & vbNewLine
    Next counter
    
    Dim emailBodyTemplate As String
    emailBodyTemplate = "This is an automated e-mail to let you know that the following CTC will expire as follow:" & vbCrLf & vbCrLf & _
                        "Name" & vbTab & vbTab & vbTab & " | " & vbTab & vbTab & vbTab & " CTC Expiry date" & vbCrLf & _
                        "<namesList>" & vbCrLf & vbCrLf & _
                        "Many Thanks " & vbCrLf & _
                        vbCrLf & "Kind Regards" & vbCrLf & vbCrLf & Environ("username")
    
    Dim emailBody As String
    emailBody = Replace(emailBodyTemplate, "<namesList>", namesList)
    
    ' Start outlook (late bound)
    Dim outApp As Object
    On Error Resume Next
    Set outApp = GetObject("Outlook.Applicatin")
    On Error GoTo 0
    
    ' If outlook is not running, start an instance
    If outApp Is Nothing Then Set outApp = CreateObject("Outlook.Application")
    Do: Loop Until Not outApp Is Nothing
    
    ' Compose email
    Dim outMail As Object
    Set outMail = outApp.CreateItem(0)
    With outMail
        .To = "Sent to"
        .CC = ""
        .BCC = ""
        .Subject = "CTC will expire soon"
        .ReadReceiptRequested = False
        .Body = emailBody
        .Display
    End With
      
    ' Display message to user
    Dim staffMessage As String
    staffMessage = ("Email has been sent for below staff")
    MsgBox staffMessage
        
    ' Clean up
    Set outApp = Nothing
    Set outMail = Nothing
    
End Sub

Let me know if it works