send email to name in one cell if date in another cell is past due

[Joe Patrick]

Hi! I'm trying to do this with a macro:

1. if date in A3 is < today minus 3
2. then send email to name in A1
3. body to include a hyperlink contained in A2

Number of rows varies.

The name in A1 is just that, a name, so I will need a series of if/thens in the macro to indicate where the ".to" should go. (Unless someone knows how to make an email address out of a name. The domain is always the same and I know the format (first initial, last name) so I can do it except for special characters like apostrophes, hyphens and extra spaces - I'll post another thread about that.)

Is there a solution for this? Thank you in advance!

 

[daverunt]

Hi Joe,

here's some code you can try.

The name splitting - there are plenty of people on this forum adept at splitting strings and this should help you generate the email address from the name in the cell.

I have used Select Case, so you'll have to hard code Addresses to Names for now.


What do you mean by - "Number of rows varies" ?

Sub Mail_on_Date()
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
 
 
Select Case Range("A1").Value
 
Case Is = "Fred Flintstone"
EmailSendTo = "[EMAIL="FFlintstone@yahoo.com"]FFlintstone@yahoo.com[/EMAIL]"
Case Is = "Joe Bloggs"
EmailSendTo = "[EMAIL="JBloggs@yahoo.com"]JBloggs@yahoo.com[/EMAIL]" 
 
End Select
 
If Sheets("Sheet2").Range("A3").Value < DateAdd("d", -3, Date) Then
 
'Subject string
EmailSubject = "Test"
MailBody = "Dear " & Range("A1").Value & vbNewLine & vbNewLine & Range("A2").Hyperlinks(1).Address
 
'Send Mail
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = EmailSubject
.To = EmailSendTo
.Body = MailBody
.Display
'.Send
 
End With
 
Set OutMail = Nothing
Set OutApp = Nothing
 
Else
MsgBox ("no mails to be sent")
End If
End Sub

 

[daverunt]

...Ok found some name splitting code.
As long as names are 'Firstname-space-<SPACE>Surname' format in 'A1' it should be ok.

Domain = "@yahoo.com"
 
Firstname = StrConv((Left(Range("A1").Value, 1)), vbLowerCase)
Surname = StrConv(Trim(Mid(Range("A1").Value, InStr(Range("A1").Value, 
" ") + 1)), vbLowerCase)
 
EmailSendTo = Firstname & Surname & Domain

 

[Joe Patrick]

daverunt,

thank you so much! that works great for 1 row. what i mean by 'number of rows varies' is sometimes there may be 5 rows of data and sometime there may be 50. I need the macro to check each row and send en email to the contact person in each row that is past due. I hope I've explained that well!

Thanx for the suggestion on the email address. I've actually already written something that worsk EXCEPT for special characters, that's what's got me stuck. I need to somehow remove any extra spaces, hyphens, apostrophes, etc. Like if the name was Joe de la F'uego-Flores I want it to wind up being jflores@specified.xxx.

 

[Joe Patrick]

This is what i've managed so far. It doesn't know when to stop so i get a runtime error:

Sub SendMultiEmails()
For Each r In ActiveSheet.Rows
If Cells(r.Row, 3).Value <= (Now() - 3) Then myTo = Cells(r.Row, 1).Value
If Cells(r.Row, 3).Value <= (Now() - 3) Then mySubject = Cells(r.Row, 2).Value
If Cells(r.Row, 3).Value <= (Now() - 3) Then
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = mySubject & " is past due"
.To = myTo
.Body = "This is past due"
.Display
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next
End Sub


So i tried this and it thinks for awhile but nothing happens. I think the first 2 lines conflict but i don't get any errors:

Sub SendMultiEmails2()
For Each r In Range("A3:Z65000")
Do Until IsEmpty(ActiveCell)
If Cells(r.Row, 3).Value <= (Now() - 3) Then myTo = Cells(r.Row, 1).Value
If Cells(r.Row, 3).Value <= (Now() - 3) Then mySubject = Cells(r.Row, 2).Value
If Cells(r.Row, 3).Value <= (Now() - 3) Then
Dim OutApp As Object
Dim OutMail As Object
Dim EmailSubject As String
Dim EmailSendTo As String
Dim MailBody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = mySubject & " is past due"
.To = myTo
.Body = "This is past due"
.Display
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End If
ActiveCell.Offset(1, 0).Select
Loop
Next
End Sub

 

[daverunt]

So to get this straight:

Name is in Column A?
Subject in Column B?
Date to check in Column C?

varying number of rows.

If this is not right please correct it.

 

[daverunt]

Hi,

Here is some code based on my assumptions above:
I haven't improved on the name splitting. I'll post it a go if I can figure it out!
Column C - check date to the last filled cell.
Column B - subject
Column A - name

Sub Mail_on_Date()
Dim OutApp As Object
Dim OutMail As Object
Dim mySubject As String
Dim myTo As String
Dim Body As String
 
Domain = "@yahoo.com"
Set Rng = Range(Range("C1"), Range("C" & Rows.Count).End(xlUp))
 
For Each cell In Rng
'Date in Column C
    If cell.Value < DateAdd("d", -3, Date) Then
 
'Name In Column A - (Offset -2)
    Firstname = StrConv((Left(cell.Offset(0, -2).Value, 1)), vbLowerCase)
    Surname = StrConv(Trim(Mid(cell.Offset(0, -2), InStr(cell.Offset(0, -2), " ") + 1)), vbLowerCase)
    MailName = Firstname & Surname & Domain
    myTo = MailName
 
'Subject in Column B - (Offset -1)
    mySubject = cell.Offset(0, -1).Value
 
'Send Mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(o)
        With OutMail
            .Subject = mySubject
            .To = myTo
            .Body = "This is past due"
            .Display
            '.Send
 
        End With
    End If
 
Next
        Set OutMail = Nothing
        Set OutApp = Nothing
End Sub

 

[daverunt]

Here's some name splitting code that replaces some characters for the names in Column A.
I don't know if some of the replacing can be concatenated.

'Name In Column A - offset -2
    CleanName = Replace(cell.Offset(0, -2).Value, "-", " ")
    CleanName = Replace(CleanName, "  ", " ")
    CleanName = Replace(CleanName, ",", "")
    CleanName = Replace(CleanName, "Any other character?", "")
 
 
    FirstInitial = StrConv((Left(CleanName, 1)), vbLowerCase)
    Surname = InStrRev(CleanName, " ")
    Surname = StrConv(Mid(CleanName, Surname + 1), vbLowerCase)
 
    MailName = FirstInitial & Surname & Domain
    myTo = MailName

 

[Joe Patrick]

daverunt, you're awesome!

i took what you did above to get my final macro:

Sub SendPastDueAlert()
Dim OutApp As Object
Dim OutMail As Object
Dim mySubject As String
Dim myTo As String
Dim Body As String
Set rng = Range(Range("K1"), Range("K" & Rows.Count).End(xlUp))
For Each cell In rng
If cell.Value < DateAdd("d", -3, Date) Then
If (cell.Offset(0, -1).Value) = "GC" Then
myTo = (cell.Offset(0, -3).Value)
Else
myTo = (cell.Offset(0, -2).Value)
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(o)
With OutMail
.Subject = "TEST TEST - " & (cell.Offset(0, -7).Value) & " - " & (cell.Offset(0, -6).Value) & " - Task ID# " & (cell.Offset(0, -10).Value) & " " & (cell.Offset(0, -8).Value) & " - PAST DUE"
.To = myTo
.Body = "file://Path\" & (cell.Offset(0, -10).Value)
.Send
End With
End If
Next
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

I'm an idiot, with outlook i can just send to a name (this is all internal for now), so i don't need to create email address. I'm keeping your code for when i need it though!

thank you, thank you, thank you!

 

[kapplebland]

I am trying to do something similar but I have rows of data with email addresses. Could i just have MailName be the column letter? Thank you in advance.