使用数据预先确定单元格以发送电子邮件

Question

我找到了下面的代码。

代码询问要选择数据的范围并发送电子邮件。我试图预先确定这些细胞，但我无法弄明白。

实施例

这是我的表，我不想每次运行代码时都选择单元格，而是希望代码从单元格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

Answer 1

而不是

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

使用

行

Set xRg = Range("A2:C6")

Answer 2

您可以替换：

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，因为如果您的代码遇到错误，您将无法看到它，因此无法更正它以纠正错误！