预先确定具有发送电子邮件数据的单元格 [英] 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.

示例

这是我的表，我不想每次运行代码时选择单元格，而是我希望代码从单元格A2：C6中获取数据

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

代码：

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

推荐答案

您可以替换：

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")

我已经包含 On Error Resume Next 因为如果您的代码遇到错误，您将看不到它，因此无法更正它以更正它！

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!

这篇关于预先确定具有发送电子邮件数据的单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！