Macro to email based on Renewal Date

[howard]

I have written code to email a recipient where "yes" appears in Col G. Where "Yes" Appears in Col "G", then I want the header as well as the rows "Yes" to be emailed to the recipient"


I cannot get the code to do this


See full code below

 Sub Email_Reminder()
    Dim Email_Subject As String, Email_Send_To As String, Email_Body As String
    Dim Mail_Object As Object, Mail_Single As Variant
    Dim r As Long
    Dim cell As Range

r = 2

Do Until Trim(Cells(r, 7).Value) = ""
    Email_Subject = Sheets("Email").Range("B1")
    Email_Send_To = Cells(r, 6).Value
    Email_Body = Sheets("Email").Range("B2")

    For Each cell In Columns("G:G")

        If cell.Value = "Yes" Then

            On Error GoTo debugs
            Set Mail_Object = CreateObject("Outlook.Application")
            Set Mail_Single = Mail_Object.CreateItem(0)
            With Mail_Single
                .Subject = Email_Subject
                .To = Email_Send_To
                .Body = Email_Body
                .Display
            End With

        End If
ResumeLoop:
    Next cell
Loop

Exit Sub
debugs:
    If Err.Description <> "" Then MsgBox Err.Description
    GoTo ResumeLoop:
End Sub

See link for sample data


https://www.dropbox.com/s/rjqsnkgpb8gj19p/Email Reminder based on Date.xlsm?dl=0

It would be appreciated if someone could assist me

I have also posted on link below

https://www.excelforum.com/excel-pr...omaticaly-send-email-based-on-renew-date.html

 

[DanteAmor]

Hi Dante
If for eg G2 = "Yes" and I2 = "NO" or Blank, the macro creates 2 emails. It should only create 1 email
Please test and amend code

You only need a For and review the data of each row

Try this

Sub email()


Dim Mail_Single As Variant, c As Range, d As Range, wFile As String
    Dim sh As Worksheet, shE As Worksheet, s As Worksheet, wb2 As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sh = Sheets("Renewals")
    Set shE = Sheets("Email")
    On Error Resume Next
    For Each c In sh.Range("G2", Range("G" & Rows.Count).End(xlUp))
   
        If c.Value = "Yes"[COLOR=#0000ff] And sh.cells(c.row, "I").value <> "Emailed" [/COLOR]Then
            For Each s In Sheets
                If UCase(s.Name) = UCase(sh.Cells(c.Row, "A").Value) Then
                    s.Copy
                    Set wb2 = ActiveWorkbook
                    wFile = ThisWorkbook.Path & "\" & s.Name & ".xlsx"
                    wb2.SaveAs wFile
                    Set Mail_Single = CreateObject("Outlook.Application").CreateItem(0)
                    With Mail_Single
                        .Subject = shE.Range("B1").Value
                        .To = sh.Cells(c.Row, "F").Value
                        .Body = shE.Range("B2").Value
                        .Attachments.Add wFile
                        .Display
                    End With
                    sh.Cells(c.Row, "I").Value = "Emailed"
                    wb2.Close False
                    Exit For
                End If
            Next
        End If
    Next
     
End Sub

 

[howard]

Hi Dante

Thanks for the amended code. If all the items in Col G are = "Yes" and Col I is either blank or contains 'No" and there are 3 items from G2 onwards, only 2 emails are generated

I tried to see what is causing this, but could not work this out


Kindly test & amend your code

https://www.dropbox.com/s/rjqsnkgpb8gj19p/Email Reminder based on Date.xlsm?dl=0

 

[DanteAmor]

It is difficult to follow you, what is the condition? in your explanation you put one but in the code you put another one. I try again:

If c.Value = "Yes" And (sh.cells(c.row, "I").value = "" or sh.cells(c.row, "I").value = "No") Then

 

[howard]

Thanks for the amended code

The sample data contained "Yes" in Col G for all items and Blanks in Col I

Emails were generated for

Simon.Davids@smt.com
barry.marks@smt.com


No email was generated for Peter.Berry@smt.com


please test and amend

https://www.dropbox.com/s/rjqsnkgpb8gj19p/Email Reminder based on Date.xlsm?dl=0

 

[DanteAmor]

Thanks for the amended code

The sample data contained "Yes" in Col G for all items and Blanks in Col I

Still have problems?
Please, Could you describe with simple examples what are the criteria you need?

 

[howard]

Hi Dante


Sorry if I was not clear in my explanation


The criteria is as follows:

If item in Col G = "Yes" and Col I contains a blank cell in same row or "No" then an email to be generated
If Item in Col G = "NO" then no email to be generated

See Examples Below

G2 = "Yes" I2 = Blank then email to be generated and sent to recipient/s in F2
G3 = "No" No email to be generated
G4 = "Yes" I4 = "Emailed" No email to be generated
G5 = 'Yes" I5 = "No" , an email to be generated and sent to recipient/s in G5

Hope this is clearer


Regards


Howard

 

[DanteAmor]

Hi Dante
Sorry if I was not clear in my explanation
The criteria is as follows:
If item in Col G = "Yes" and Col I contains a blank cell in same row or "No" then an email to be generated
If Item in Col G = "NO" then no email to be generated
See Examples Below
G2 = "Yes" I2 = Blank then email to be generated and sent to recipient/s in F2
G3 = "No" No email to be generated
G4 = "Yes" I4 = "Emailed" No email to be generated
G5 = 'Yes" I5 = "No" , an email to be generated and sent to recipient/s in G5 You mean G2
Hope this is clearer
Regards
Howard

Try

Sub email()
    Dim Mail_Single As Variant, c As Range, d As Range, wFile As String
    Dim sh As Worksheet, shE As Worksheet, s As Worksheet, wb2 As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sh = Sheets("Renewals")
    Set shE = Sheets("Email")
    On Error Resume Next
    For Each c In sh.Range("G2", Range("G" & Rows.Count).End(xlUp))
   
        If c.Value = "Yes"  Then
         [COLOR=#0000ff] if sh.cells(c.row, "I").value = "" or sh.cells(c.row, "I").value = "No" then[/COLOR]
            For Each s In Sheets
                If UCase(s.Name) = UCase(sh.Cells(c.Row, "A").Value) Then
                    s.Copy
                    Set wb2 = ActiveWorkbook
                    wFile = ThisWorkbook.Path & "\" & s.Name & ".xlsx"
                    wb2.SaveAs wFile
                    Set Mail_Single = CreateObject("Outlook.Application").CreateItem(0)
                    With Mail_Single
                        .Subject = shE.Range("B1").Value
                        .To = sh.Cells(c.Row, "F").Value
                        .Body = shE.Range("B2").Value
                        .Attachments.Add wFile
                        .Display
                    End With
                    sh.Cells(c.Row, "I").Value = "Emailed"
                    wb2.Close False
                    Exit For
                End If
            Next
          End if
        End If
    Next
End Sub

 

[howard]

Hi Dante

Thanks for the amended Code. The logic I supplied to you is correct. I tested with "NO" in Col G and no emails generated, which I correct

Where I have Yes in G2, G3 & G4, and either "NO" or a blank in Col I, emails are sent to the recipients for G2 & G3 criteria being Yes but not for G4

I have highlighted G4 in Yellow as I do not know why nothing generated for this when G4 = "Yes" and I4 is a blank cell

Please test & amend

https://www.dropbox.com/s/rjqsnkgpb8gj19p/Email Reminder based on Date.xlsm?dl=0

 

[DanteAmor]

Hi Dante

Thanks for the amended Code. The logic I supplied to you is correct. I tested with "NO" in Col G and no emails generated, which I correct

Where I have Yes in G2, G3 & G4, and either "NO" or a blank in Col I, emails are sent to the recipients for G2 & G3 criteria being Yes but not for G4

I have highlighted G4 in Yellow as I do not know why nothing generated for this when G4 = "Yes" and I4 is a blank cell

Please test & amend

https://www.dropbox.com/s/rjqsnkgpb8gj19p/Email Reminder based on Date.xlsm?dl=0

The conditions are case sensitive, try this:

        If lcase(c.Value) = lcase("Yes")  Then
          if sh.cells(c.row, "I").value = "" or lcase(sh.cells(c.row, "I").value) = lcase("No") then

It also checks that the cell is empty, that is, that there are no blank spaces.

 

[howard]

Hi Dante

The last item (G4) contains "Yes" and I4 is Blank, but no email is generated


See full code below

 Sub email()
    Dim Mail_Single As Variant, c As Range, d As Range, wFile As String
    Dim sh As Worksheet, shE As Worksheet, s As Worksheet, wb2 As Workbook
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set sh = Sheets("Renewals")
    Set shE = Sheets("Email")
    On Error Resume Next
    For Each c In sh.Range("G2", Range("G" & Rows.Count).End(xlUp))
   
        If LCase(c.Value) = LCase("Yes") Then
          If sh.Cells(c.Row, "I").Value = "" Or LCase(sh.Cells(c.Row, "I").Value) = LCase("No") Then
            For Each s In Sheets
                If UCase(s.Name) = UCase(sh.Cells(c.Row, "A").Value) Then
                    s.Copy
                    Set wb2 = ActiveWorkbook
                    wFile = ThisWorkbook.Path & "\" & s.Name & ".xlsx"
                    wb2.SaveAs wFile
                    Set Mail_Single = CreateObject("Outlook.Application").CreateItem(0)
                    With Mail_Single
                        .Subject = shE.Range("B1").Value
                        .To = sh.Cells(c.Row, "F").Value
                        .Body = shE.Range("B2").Value
                        .Attachments.Add wFile
                        .Display
                    End With
                    sh.Cells(c.Row, "I").Value = "Emailed"
                    wb2.Close False
                    Exit For
                End If
            Next
          End If
        End If
    Next
End Sub