Macro to email based on Renewal Date

howard

Well-known Member
Joined
Jun 26, 2006
Messages
6,561
Office Version
  1. 2021
Platform
  1. Windows
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





Code:
 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
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Try this
Create a sheet called "Temp"

Code:
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
 
Upvote 0
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
 
Upvote 0
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).
 
Last edited:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
Further to my post # 6 , I want the relevant sheet attached to the email
 
Last edited:
Upvote 0
Further to my post # 6 , I want the relevant sheet attached to the email

ok, try this new code

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
 
Upvote 0
Hi Dante

Thanks very much. Code now works 100%
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,489
Messages
6,113,954
Members
448,535
Latest member
alrossman

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top