# Macro to email based on Renewal Date



## howard (Jun 30, 2019)

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 (Jun 30, 2019)

Try this
Create a sheet called "Temp"


```
Sub Email_Reminder()
    Dim Email_Body As String, Mail_Single As Variant
    Dim c As Range, sht As Worksheet, rng As Range
    
    Set sht = Sheets("[COLOR=#ff0000]Temp[/COLOR]")
    sht.Cells.ClearContents
    Rows(1).Copy sht.Rows(1)
    On Error Resume Next
    For Each c In Range("G2", Range("G" & Rows.Count).End(xlUp))
        If c.Value = "Yes" Then
            c.EntireRow.Copy sht.Rows(2)
            Set rng = sht.Range("A1:G2")
            Set Mail_Single = CreateObject("Outlook.Application").CreateItem(0)
            With Mail_Single
                .Subject = Sheets("Email").Range("B1").Value
                .To = Cells(c.Row, "F").Value
                .HTMLBody = RangetoHTML(rng)
                .Display
            End With
        End If
    Next
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    'TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    TempFile = "C:\trabajo\temp.htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
```


----------



## howard (Jun 30, 2019)

Thanks Dante

I need the following changes. 

1) I need the body of the email to contain what is on sheet "Email"
2) I need to email a separate sheet to each recipient where "Y" is in Col G

Your assistance in this regard is most appreciated


----------



## DanteAmor (Jun 30, 2019)

howard said:


> Thanks Dante
> 
> I need the following changes.
> 
> ...




I do not understand what sheets you have.
You can explain with examples what datas you have in which sheet and what you want in the body of the mail.

Please Note
-----------------------
One thing you must keep in mind when you ask a question in a forum... the people you are asking to help you know absolutely nothing about your data, absolutely nothing about how it is laid out in the workbook, absolutely nothing about what you want done with it and absolutely nothing about how whatever it is you want done is to be presented back to you as a result... you must be very specific about describing each of these areas, in detail, and you should not assume that we will be able to "figure it out" on our own. Remember, you are asking us for help... so help us to be able to help you by providing the information we need to do so, even if that information seems "obvious" to you (remember, it is only obvious to you because of your familiarity with your data, its layout and the overall objective for it).


----------



## howard (Jun 30, 2019)

Hi Dante

My Apologies for not being clear. I will get back to you tomorrow to explain step by step exactly what I require


Regards


Howard


----------



## howard (Jun 30, 2019)

Hi Dante

The sheet containing all the data is "Renewals"

The "Subject" for the email is in cell B1 on sheet "Email" and the body of the email is contained in B2 on sheet "Email"

I would like a macro to generate send an Email where "Yes" appears in Col G on all sheets except "Renewals" & "Email"  


See updated file per link below

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


I hope my explanation is clear and makes sense


----------



## howard (Jun 30, 2019)

Further to my post # 6 , I want the relevant sheet attached to the email


----------



## DanteAmor (Jul 2, 2019)

howard said:


> Further to my post # 6 , I want the relevant sheet attached to the email



ok, try this new code


```
Sub Email_Reminder()
    Dim Mail_Single As Variant, c 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
            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
                    wb2.Close False
                    Exit For
                End If
            Next
        End If
    Next
End Sub
```


----------



## howard (Jul 2, 2019)

Hi Dante

Thanks very much. Code now works 100%


----------



## howard (Jul 2, 2019)

Dante I have one more request

Once Email has been generated, I would like to insert "Emailed" in Col I in the same row as the items that were emailed

It would be appreciated if you could incorporate this in your code if this is at all possible


----------



## howard (Jun 30, 2019)

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 (Jul 2, 2019)

howard said:


> Dante I have one more request
> 
> Once Email has been generated, I would like to insert "Emailed" in Col I in the same row as the items that were emailed
> 
> It would be appreciated if you could incorporate this in your code if this is at all possible




Try this


```
Sub Email_Reminder()
    Dim Mail_Single As Variant, c 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
            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
                    [COLOR=#0000ff]sh.Cells(c.Row, "I").Value = "Emailed"[/COLOR]
                    wb2.Close False
                    Exit For
                End If
            Next
        End If
    Next
End Sub
```


----------



## howard (Jul 2, 2019)

Hi Dante

Thanks very much this is perfect


----------



## DanteAmor (Jul 3, 2019)

howard said:


> Hi Dante
> 
> Thanks very much this is perfect



I'm glad to help you. Thanks for the feedback.


----------



## howard (Jul 3, 2019)

Hi Dante


I checked your data again today and 4 emails are generated and only 3 should be generated

Kindly test and amend code


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


----------



## DanteAmor (Jul 3, 2019)

howard said:


> Hi Dante
> 
> I checked your data again today and 4 emails are generated and only 3 should be generated
> Kindly test and amend code
> https://www.dropbox.com/s/rjqsnkgpb8gj19p/Email Reminder based on Date.xlsm?dl=0




If the cell says "yes" then an email is generated


----------



## howard (Jul 3, 2019)

I amended your code slightly that that if "yes"  appears in Col G & "emailed" appears in Col I not to send an email


Kindly test & amend


----------



## DanteAmor (Jul 3, 2019)

howard said:


> I amended your code slightly that that if "yes"  appears in Col G & "emailed" appears in Col I not to send an email
> 
> 
> Kindly test & amend



So, does it work?


----------



## howard (Jul 3, 2019)

Hi Dante

Your original code worked 100% , but I added an additional Criteria as follows:

1) If Col G = "Yes" and Col I = "NO" or Blank , then generate an email using recipient/s in Col F in same row as criteria
2) If Col G = "Yes" and Col I = "Emailed" no email to be generated
3) If Col G = "No' then no email to be generated


See my 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))
    For Each d In sh.Range("I2", Range("I" & Rows.Count).End(xlUp))
        If c.Value = "Yes" And d.Value <> "Emailed" 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
     Next
End Sub
```


See link to workbook on Dropbox



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


----------



## DanteAmor (Jul 3, 2019)

howard said:


> Hi Dante
> 
> Your original code worked 100% , but I added an additional Criteria as follows:
> 
> ...



Ok, you added more criteria, but it works, or I do not understand why the file


----------



## howard (Jul 3, 2019)

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


----------



## howard (Jun 30, 2019)

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 (Jul 3, 2019)

howard said:


> 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 (Jul 3, 2019)

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 (Jul 4, 2019)

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 (Jul 4, 2019)

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 (Jul 4, 2019)

howard said:


> 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 (Jul 4, 2019)

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 (Jul 4, 2019)

howard said:


> 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
> ...



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 (Jul 4, 2019)

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 (Jul 5, 2019)

howard said:


> 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
> 
> ...



*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 (Jul 5, 2019)

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
```


----------



## howard (Jun 30, 2019)

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 (Jul 5, 2019)

howard said:


> Hi Dante
> 
> The last item (G4) contains "Yes" and I4 is Blank, but no email is generated
> See full code below



I did not want to download your file so that you could somehow learn to solve the problems of your data.
But, I downloaded the file and the problem with the G4 registry is that there is no BR3 sheet in your file.
If the sheet does not exist, then the file is not generated and then it does not send the mail.


----------



## howard (Jul 5, 2019)

Hi Dante

I went through your code line by line and tried a few things but could not get it to work. I did not realise that I had not set up sheet BR3

My sincere apologies for this

Many thanks for all your help. Code works perfectly


Regards


Howard


----------



## DanteAmor (Jul 5, 2019)

howard said:


> Hi Dante
> 
> I went through your code line by line and tried a few things but could not get it to work. I did not realise that I had not set up sheet BR3
> 
> ...



it happens to everyone, there are details that escape and that is part of learning. but I'm glad to know that it works. Thanks for the feedback.


----------



## howard (Jul 5, 2019)

I will never forget this again. Once again thanks for all your patience and effort

I have learnt a lot from your code


----------

