Help needed with Excel VBA code for sending E-mails only to people based on project status change condition

[racsng]

Hi,
I need to write a code where out of a dynamic list of records in Excel, I need to send mails only to people (say to 3 out of 5 records) whose project status change date is approaching within 7 days. These people need to be notified about due date and are required to change project status in the system.

Condition:
Only if when due date is within 7 days, mail will be sent (display first for any edits) from outlook to the project owner, cc two other persons

Issue:
My code is returning only one e-mail, that to for the last record in the given list. I want it to display mails for all cases that satisfy given condition.

Table headers are in row 3 and data rows start from row 4.

I would really appreciate any help with the code below. Thank you!


Sample data:

A	B	C	D	E	F	G
Project Name	No. of days Due	PM First Name	AM e-mail	Email Cc1	Email Cc2	E-mail Message
ABC	7	PM1	PM1@abc.com	CC1@abc.com	CC2@abc.com	Change status
CDE	12	PM2	PM2@abc.com	CC1@abc.com	CC2@abc.com
PQR	6	PM3	PM3@abc.com	CC1@abc.com	CC2@abc.com	Change status
LMN	15	PM4	PM4@abc.com	CC1@abc.com	CC2@abc.com
TGS	7	PM5	PM5@abc.com	CC1@abc.com	CC2@abc.com	Change status

VBA Code:

Option Explicit

Sub OptInFlagNotification()

Application.ScreenUpdating = False

'Defining outlook variables
Dim OutApp As Object
Dim OutMail As Object

'Variables allocated
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

Dim EmailTo As String
Dim EmailCc1 As String
Dim EmailCc2 As String
Dim EmailToAddress As String
Dim EmailMessage As String
Dim LastRow As Integer
Dim RowCounter As Integer


Dim NextParagraph As String
NextParagraph = vbNewLine & vbNewLine


LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

For RowCounter = 4 To LastRow
   
' to run only when E-mail message is not blank in column G , i.e. when due is date within 7 days from now
    If Cells(RowCounter, 6).Value <> "" Then
   
        EmailToAddress = Sheet1.Range("D" & RowCounter).Value
        EmailCc1 = Sheet1.Range("E" & RowCounter).Value
        EmailCc2 = Sheet1.Range("F" & RowCounter).Value
        EmailTo = Sheet1.Range("C" & RowCounter).Value
        EmailMessage = Sheet1.Range("G" & RowCounter).Value
       
       
       With OutMail
                .to = EmailToAddress
                .cc = EmailCc1 & "; " & EmailCc2
                .Subject = "Project status change Alert"
                .Body = "Hi " & EmailTo & NextParagraph _
                & EmailMessage _
                & NextParagraph & "Thank you," & vbNewLine & _
                "XYZ"
                .Display
              
         End With
               
     End If
    

Next RowCounter

Set OutApp = Nothing
Set OutMail = Nothing

Application.ScreenUpdating = True


End Sub

 

[Micron]

I'll bet you didn't step through this code and watch what happens. That's trouble shooting 101. I can tell you what's wrong and how to fix it, but would you rather try practicing that trouble shooting method for yourself first?
Clue - add RowCounter to the email body for proof positive.

 

[racsng]

I'll bet you didn't step through this code and watch what happens. That's trouble shooting 101. I can tell you what's wrong and how to fix it, but would you rather try practicing that trouble shooting method for yourself first?
Clue - add RowCounter to the email body for proof positive.

Thanks for the reply & clue. I'm kind of a beginner!
I did step through code & also tried counter to the mail body - not working for me, still getting to see only one final e-mail message to edit in the end! There should be 3 windows for different e-mails displayed as the final outcome.

 

[racsng]

I'll bet you didn't step through this code and watch what happens. That's trouble shooting 101. I can tell you what's wrong and how to fix it, but would you rather try practicing that trouble shooting method for yourself first?
Clue - add RowCounter to the email body for proof positive.

Finally got it! Thank you!

I've done following change to the code:
added counter 'i'

Dim i as integer

i = 4
For RowCounter = 4 To LastRow
   
' to run only when E-mail message is not blank in column G , i.e. when due is date within 7 days from now
    If Cells(RowCounter, 6).Value <> "" Then
   
        EmailToAddress = Sheet1.Range("D" & RowCounter).Value
        EmailCc1 = Sheet1.Range("E" & RowCounter).Value
        EmailCc2 = Sheet1.Range("F" & RowCounter).Value
        EmailTo = Sheet1.Range("C" & RowCounter).Value
        EmailMessage = Sheet1.Range("G" & RowCounter).Value
       
       
       With OutMail
                .to = EmailToAddress
                .cc = EmailCc1 & "; " & EmailCc2
                .Subject = "Project status change Alert"
                .Body = "Hi " & EmailTo & NextParagraph _
                & EmailMessage _
                & NextParagraph & "Thank you," & vbNewLine & _
                "XYZ"
                .Display
              
         End With

i = i + 1
               
     End If
    

Next RowCounter

 

[Micron]

I was thinking
For RowCounter = 4 To LastRow
Set OutMail = OutApp.CreateItem(0)

so that the object is created on each pass, but if your way works for you, then that's good too. Your problem was that it was being replaced. That's why I suggested adding the variable; you'd see that the only email you ended up with was the last one. Not sure why you start at row 4 based on your sample data? You might want to set up a limit on a loop like this. A little mistake can have you creating thousands of emails by accident.