Macro to email based on Renewal Date

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,555
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
 

Some videos you may like

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,104
Office Version
2007
Platform
Windows
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
 

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,555
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,104
Office Version
2007
Platform
Windows
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:

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,555
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

Well-known Member
Joined
Jun 26, 2006
Messages
5,555
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

Well-known Member
Joined
Jun 26, 2006
Messages
5,555
Further to my post # 6 , I want the relevant sheet attached to the email
 
Last edited:

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,104
Office Version
2007
Platform
Windows
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
 

howard

Well-known Member
Joined
Jun 26, 2006
Messages
5,555
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
 

Watch MrExcel Video

Forum statistics

Threads
1,101,996
Messages
5,484,089
Members
407,430
Latest member
sgoldman

This Week's Hot Topics

  • Finding issue in If elseif else with For each Loop
    Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
  • MsgBox Error
    Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
  • CELL FORMAT - IF CONDITION
    My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
  • Show numbers nearly the same
    Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...
  • Please i need your help to create formula
    I need a formula in cell B8 to do this >>if b1=1 then multiply ( cell b8) by 10% ,if b1=2 multiply by 20%,if=3 multiply by 30%. Thank you in...
  • Got error while adding column and filter
    Got error while adding column and filter In column Z has some like "Success" and "Error". I want to add column in AA if the Z cell value is...
Top