Send email based on due dates

Hi

I have recently located someones coding from these pages to send emails based on specific due dates. I was provided with the below code which sort of works, however, if the code identifies more than one person with the same end date, it only shows the email for the last person listed. The code will update the spreadsheet to say it has identified and created an email however, it will only show 1 x pane to be sent and not the seven it has identified.

ANY HELP WOULD BE APPRECIATED

 Private Sub Workbook_Open()

   
    Dim i As Long
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    
    
    For i = 2 To Range("C65536").End(xlUp).Row
        If Cells(i, 43) <> "Y" Then
            If Cells(i, 21) - 14 < Date Then
                
                strto = Cells(i, 44).Value 'email address
                strsub = "PSR Contractor " & Cells(i, 6).Value & " is due on Due date " & Cells(i, 21).Value 'email subject
                strbody = "Dear " & Cells(i, 6).Value & vbNewLine & "please update your project status" 'email body
                
                With OutMail
                    .To = strto
                    .Subject = strsub
                    .Body = strbody
                    '.Send
                    .display
                                    
                End With
                On Error Resume Next
                Cells(i, 42) = "Mail Sent " & Now()
                Cells(i, 43) = "Y"
                
            End If
        End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    

End Sub

Administrative Note:

Welcome to the forum.

We would very much like to help you with your query, however you need to include code tags around your code.

Please take a moment to add the tags. Posting code between tags makes your code much easier to read and copy for testing, and it also maintains VBA formatting.

Please see Forum Rule #2 about code tags and adjust accordingly. Click on Edit to open your post, then highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

(Note: this change is not optional. No help to be offered until this moderation request has been fulfilled.)

Do you have sample worksheet

It will be a very hard guess work to figure out where the dates are and WHEN you said that its NOT working, why its not working WITHOUT A SPREADSHEET.

Try This variation to your code

Private Sub Workbook_Open()

   
    Dim i As Variant
    Dim OutApp, OutMail As Object
    Dim strto, strcc, strbcc, strsub, strbody As String
    Dim today As Date
    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
    today = Date
    
    For i = 3 To Range("C65536").End(xlUp).Row
       ' If Cells(i, 43) <> "Y" Then
            If (Cells(i, 3) - 30) < today Then
                strto = Cells(i, 4).Value 'email address
                strsub = "PSR Contractor - Due date " & Cells(i, 3).Value 'email subject
                strbody = "Dear " & Cells(i, 2).Value & vbNewLine & "please update your project status" 'email body
                
                With OutMail
                    .To = strto
                    .Subject = strsub
                    .Body = strbody
                    .Send
                   ' .display
                                    
                End With
                On Error Resume Next
                Cells(i, 5) = "Mail Sent " & Now()
                'Cells(i, ) = "Y"
                
            End If
        'End If
    Next
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    

End Sub