调用函数发送没有这么多代码在Excel中的电子邮件

我有一个Excel电子表格，select预先定义的单元格，并从此创build和电子邮件时，用户按下button。 当我有大约3到4行数据，但现在我有超过500行，这工作得很好。

请在这里露面，因为我在VBA编码不太好。 我想要做的是，而不是重复每行的代码有一个函数，每次被调用。 我希望代码能够从行末尾的链接中获得行（我还需要弄清楚如何链接到VBA，我知道如何通过button来完成，但每个末尾都有一个链接行会好得多）。 链接会说发送电子邮件。 如果用户按下该链接，则将select链接所在的行并发送电子邮件。 希望是有道理的。 我只想要1个函数，这可以从中调用。 而不必每一次为每一行复制代码。

任何好的方法来做到这一点？ 请参阅下面的代码和电子表格。

Sub SendEmail() Dim objOutlook As Outlook.Application Set objOutlook = New Outlook.Application Dim objEmail As Outlook.MailItem Set objEmail = objOutlook.CreateItem(olMailItem) objEmail.Subject = Cells(2, 1).Text objEmail.Body = "============" & vbNewLine & Cells(2, 3).Text & vbNewLine & "============" & vbNewLine & Cells(2, 6).Text objEmail.To = Cells(2, 5).Text objEmail.SentOnBehalfOfName = "[e-mail]" objEmail.Display End Sub 

我还附上了一个电子表格的例子。 请注意电子表格上的完整logging超过500条。 这是一个非常简洁的版本：

>>链接到示例工作簿

Answer 1

您也可以尝试以下方法：

 Sub SendEmail(r As Range) Dim objOutlook As Outlook.Application Set objOutlook = New Outlook.Application Dim objEmail As Outlook.MailItem Set objEmail = objOutlook.CreateItem(olMailItem) With objEmail .Subject = r.Value2 .Body = "============" & vbNewLine & r.Offset(0, 2).Value2 & vbNewLine & _ "============" & vbNewLine & r.Offset(0, 5).Value2 .To = r.Offset(0, 4).Value2 .SentOnBehalfOfName = "[e-mail]" .Display End With End Sub 

然后testing一下：

 Sub Test() Dim lr As Long, cel As Range With Sheets("SheetName") lr = .Range("A" & .Rows.Count).End(xlUp).Row If lr = 1 Then Msgbox "No email to send": Exit Sub For Each cel In .Range("A2:A" & lr) SendEmail cel Next End With End Sub 

编辑：按超链接时发送邮件，您可以使用工作表事件。

 Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink) Application.EnableEvents = False On Error GoTo halt If Target.Name = "Send Mail" Then '<~~ Check which hyperlink is pressed '*** This will call the SendEmail routine above and pass '*** the range where the hyperlink is on '*** Take note of the Offset(0, -5). I just based it on your screen shot '*** where your subject is 5 cells from the cell with Send mail '*** Adjust it to your actual target range Application.Run SendEmail, Target.Range.Offset(0, -5) 'SendEmail Target.Range.Offset(0, -5) End If moveon: Application.EnableEvents = True Exit Sub halt: MsgBox Err.Description Resume moveon End Sub 

我使用了Application.Run以便您不必担心SendEmail子例程是否为Public 。 如果您决定在模块中 公开 ，您可以使用注释行。

Answer 2

使用select的行。 select你的行，然后从选定的范围中获取行，并将其用于单元格的代码（iRow，1）

 Sub SendEmail() Dim ActSheet As Worksheet Dim SelRange As Range Dim iRow As Integer Set ActSheet = ActiveSheet Set SelRange = Selection iRow = SelRange.Row Dim objOutlook As Outlook.Application Set objOutlook = New Outlook.Application Dim objEmail As Outlook.MailItem Set objEmail = objOutlook.CreateItem(olMailItem) objEmail.Subject = Cells(iRow , 1).Text objEmail.Body = "============" & vbNewLine & Cells(iRow , 3).Text & vbNewLine & "============" & vbNewLine & Cells(iRow , 6).Text objEmail.To = Cells(iRow , 5).Text objEmail.SentOnBehalfOfName = "[e-mail]" objEmail.Display End Sub 

Answer 3

在这里你如何获得所有的行，并在所有的行上运行你的子。

 Sub sendEmailFromAllRows() 'Getting the last used row With Sheets("YourSheetName") If Application.WorksheetFunction.CountA(.Cells) <> 0 Then lastrow = .Cells.Find(What:="*", _ After:=.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Else lastrow = 1 End If End With 'Calling your sub to send the mail for each row For i = 2 To lastrow SendEmail (i) Next i End Sub Sub SendEmail(iRow As Integer) Dim objOutlook As Outlook.Application Set objOutlook = New Outlook.Application Dim objEmail As Outlook.MailItem Set objEmail = objOutlook.CreateItem(olMailItem) objEmail.Subject = Cells(iRow, 1).Text objEmail.Body = "============" & vbNewLine & Cells(iRow, 3).Text & vbNewLine & "============" & vbNewLine & Cells(iRow, 6).Text objEmail.To = Cells(iRow, 5).Text objEmail.SentOnBehalfOfName = "[e-mail]" objEmail.Display objEmail.Send End Sub