CODEWITHSUNDEEP
excelvbaoutlook
Lucas Senne
Lucas Senne

Reputation: 19

Predetermine the cells with the data to send emails

I found the code below.

The code asks for the range with the data to be selected and sends the emails. I tried to predetermine these cells but I could not figure it out.

Example

This is my table, I do not want to select the cells every time I run the code, instead I would like the code take the data from cells A2:C6

This is my table, I do not want to select the cells everytime I run the code, instead of that I would like to predetermine to always when I run the code the macro will take the data from cells A2:C6

The code: 

Sub SendEMail()
'update by Extendoffice 20160506
Dim xEmail As String
Dim xSubj As String
Dim xMsg As String
Dim xURL As String
Dim i As Integer
Dim k As Double
Dim xCell As Range
Dim xRg As Range
Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 3 Then
    MsgBox " Regional format error, please check", , "Kutools for Excel"
    Exit Sub
End If
For i = 1 To xRg.Rows.Count
'       Get the email address
    xEmail = xRg.Cells(i, 2)
'       Message subject
    xSubj = "Your Registration Code"
'       Compose the message
    xMsg = ""
    xMsg = xMsg & "Dear " & xRg.Cells(i, 1) & "," & vbCrLf & vbCrLf
    xMsg = xMsg & " This is your Registration Code "
    xMsg = xMsg & xRg.Cells(i, 3).Text & "." & vbCrLf & vbCrLf
    xMsg = xMsg & " please try it, and glad to get your feedback! " & vbCrLf
    xMsg = xMsg & "Skyyang"
'       Replace spaces with %20 (hex)
    xSubj = Application.WorksheetFunction.Substitute(xSubj, " ", "%20")
    xMsg = Application.WorksheetFunction.Substitute(xMsg, " ", "%20")
'       Replace carriage returns with %0D%0A (hex)
    xMsg = Application.WorksheetFunction.Substitute(xMsg, vbCrLf, "%0D%0A")
'       Create the URL
    xURL = "mailto:" & xEmail & "?subject=" & xSubj & "&body=" & xMsg
'       Execute the URL (start the email client)
    ShellExecute 0&, vbNullString, xURL, vbNullString, vbNullString, vbNormalFocus
'       Wait two seconds before sending keystrokes
    Application.Wait (Now + TimeValue("0:00:02"))
    Application.SendKeys "%s"
Next
End Sub

Upvotes: 0

Views: 276

Answers (2)

R3uK
R3uK

Reputation: 14537

You can replace :

Dim xTxt As String
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("Please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
If xRg.Columns.Count <> 3 Then
    MsgBox " Regional format error, please check", , "Kutools for Excel"
    Exit Sub
End If

by :

Set xRg = ActiveSheet.Range("A2:C6")

I've included On Error Resume Next because if your code runs into an error, you'll not see it and hence cannot correct it to correct it!

Upvotes: 1

user7857211
user7857211

Reputation:

Instead of

Set xRg = Application.InputBox("Please select the data range:", "Kutools for Excel", xTxt, , , , , 8)

use the line

Set xRg = Range("A2:C6")

Upvotes: 1

Related Questions