Question

我有一个excel电子表格，可以选择预定义的单元格，并在用户按下按钮时创建并发送电子邮件。当我有大约3到4行数据时这很好用，但现在我有超过500行。

我想要做的是不是重复每行的代码，而是每次调用一个函数。我希望代码能够从Row末尾的链接中找出行（我还需要弄清楚如何链接到VBA，我知道如何通过按钮进行操作，但每个末尾都有一个链接排会好多了）。链接将说发送电子邮件。如果用户按下此链接，则会选择链接所在的行并发送电子邮件。希望有道理。我只想要一个可以调用的函数。而不是每次都为每一行复制代码。

这样做的好方法是什么？请参阅下面的代码和电子表格。

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 = "test@test.com"
objEmail.Display
End Sub

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

>> LINK to sample workbook

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 = "test@test.com"
        .Display
    End With
End Sub

然后测试一下：

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

使用选择中的行。选择你的行，然后从所选范围中获取行，并在代码中使用它（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 = "test@test.com"
objEmail.Display
End Sub

Answer 3

这里是如何获取所有行并在所有行上运行sub的。

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 = "test@test.com"
    objEmail.Display
    objEmail.Send
End Sub

调用函数在Excel中没有太多代码的情况下发送电子邮件

3 个答案: