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

我发现下面的代码。

代码要求select数据的范围并发送电子邮件。 我试图预先确定这些细胞，但我无法弄清楚。

例

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

您可以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 

通过：

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

我已经包括On Error Resume Next因为如果你的代码运行到错误，你不会看到它，因此不能纠正它来纠正它！

Answer 2

代替

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

使用该行

 Set xRg = Range("A2:C6")