VBA Send Email from Excel (almost complete)

Hi all,


I have the attached doc which is almost complete i need the following help

1, need the VBA to look in column H and where it is blank then send email to the email in B (this bit is working and what is in the email etc is done)
2,I need it so it doesn't stop at row 3 which it currently does.

All help would be amazing!!!confused:

Looking in your code, you have the following:

For r = 2 To 3 'data in rows 2-3
'       Get the email address
        Email = Cells(r, 2)

Which is why it would be stopping - you need to set a variable to count the number of used rows and call

For r = 2 to x

Hi thank you for the above so how do i go about that?

Here is your new code:

Sub SendEMail()
    Dim Email As String, Subj As String
    Dim Msg As String, URL As String
    Dim r As Long, s as Long x As Double
    s = ActiveSheet.UsedRange.Rows.Count
    For r = 2 To s 
'       Get the email address
        Email = Cells(r, 2)
        
'       Message subject
        Subj = "Deal Registration Expiring" & " " & Cells(r, 4) & " " & "for" & " " & Cells(r, 6)

'       Compose the message
        Msg = ""
        Msg = Msg & "Dear " & Cells(r, 1) & "," & vbCrLf & vbCrLf
        Msg = Msg & "Your deal registration for " & Cells(r, 3) & " " & Cells(r, 4) & " " & Cells(r, 5) & " " & Cells(r, 6) & " " & "is about to expire. Please respond with a brief update and new expected closure if this deal is still live - otherwise this deal will be closed and marked as lost."

        Msg = Msg & " " & vbCrLf
        Msg = Msg & "My Name" & vbCrLf
        Msg = Msg & "Registration Manager"
        
'       Replace spaces with %20 (hex)
        Subj = Application.WorksheetFunction.Substitute(Subj, " ", "%20")
        Msg = Application.WorksheetFunction.Substitute(Msg, " ", "%20")
                
'       Replace carriage returns with %0D%0A (hex)
        Msg = Application.WorksheetFunction.Substitute(Msg, vbCrLf, "%0D%0A")
'       Create the URL
        URL = "mailto:" & Email & "?subject=" & Subj & "&body=" & Msg

'       Execute the URL (start the email client)
        ShellExecute 0&, vbNullString, URL, vbNullString, vbNullString, vbNormalFocus

'       Wait two seconds before sending keystrokes
        Application.Wait (Now + TimeValue("0:00:02"))
        Application.SendKeys "%s"
    Next r
End Sub

First thing that is perfect and worked like a dream but how do i get it to check if there is a YES in Column H first adn if a yes no email is sent if blank then send email? Thank you for your help.

estratosphere,

Nice code. FYI you missed a comma in the line

Dim r As Long, s as Long, x As Double

Regards,

BigDawg15

I did the notice it come up red but luckily I worked the comma out lol Any ideas on the if question above?

Originally Posted by BigDawg15

estratosphere,

Nice code. FYI you missed a comma in the line

Dim r As Long, s as Long, x As Double

Regards,

BigDawg15

Whoops! Thanks for the spot!