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]

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]

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]

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

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]

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]

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]

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

 

[DanteAmor]

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]

Hi Dante

Thanks very much. Code now works 100%

 

[howard]

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