如何从Excel发送个性化电子邮件？

Question

我有一个经理姓名列表和未提交时间表的员工的电子邮件地址。 我需要一个代码来创建发送给每个经理的电子邮件，其中包含未提交时间表的员工的姓名。 有什么建议吗？ 该文件如下所示

approval name   Approval Email address  Employee name
test 1          test@yahoo              Test 11
test 2          test@hotmail.com        test 10
test 3          test@gmail.com          test 9

如何更改代码以发送给每个成员而不是一封电子邮件

sub sendmultiple()
'
    Dim xOTApp As Object
    Dim xMItem As Object
    Dim xCell As Range
    Dim xRg As Range
    Dim xEmailAddr As String
    Dim xTxt As String
    On Error Resume Next
    xTxt = ActiveWindow.RangeSelection.Address
    Set xRg = Application.InputBox("Please select the addresses list:", "Kutools for Excel", xTxt, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xOTApp = CreateObject("Outlook.Application")
    For Each xCell In xRg
        If xCell.Value Like "*@*" Then
            If xEmailAddr = "" Then
                xEmailAddr = xCell.Value
            Else
                xEmailAddr = xEmailAddr & ";" & xCell.Value
            End If
        End If
    Next
    Set xMItem = xOTApp.CreateItem(0)
    With xMItem
        .To = xEmailAddr
        .Display
    End With
End Sub

Answer 1

由于这看起来像是作业，因此我将为您提供一个非功能性的示例，向您展示总体结构

Sub sendmultiple()
  Dim lRow As Long
  Dim oMailItem As Object
  lRow = 2

  [code to create Outlook application object goes here]
  Do Until Range("A" & lRow) = ""
    [code to Set oMailItem goes here]
    With oMailItem
      .To = Range("B" & lRow)       ' the email address it goes to
      .Subject = Range("A" & lRow)  ' the name of approval person, not sure why
      .HTMLBody = Range("C" & lRow) ' the person the email is about
      .Send
    End With
    lRow = lRow + 1
  Loop

End Sub

Answer 2

进行较小的修改，您就应该能够完全按照您的要求进行操作。

In column A : Names of the people
In column B : E-mail addresses
In column C:Z : Filenames like this C:\Data\Book2.xls (don't have to be Excel files)

The Macro will loop through each row in "Sheet1" and if there is a E-mail address in column B
and file name(s) in column C:Z it will create a mail with this information and send it.

Sub Send_Files()
'Working in Excel 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
    Dim OutApp As Object
    Dim OutMail As Object
    Dim sh As Worksheet
    Dim cell As Range
    Dim FileCell As Range
    Dim rng As Range

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set sh = Sheets("Sheet1")

    Set OutApp = CreateObject("Outlook.Application")

    For Each cell In sh.Columns("B").Cells.SpecialCells(xlCellTypeConstants)

        'Enter the path/file names in the C:Z column in each row
        Set rng = sh.Cells(cell.Row, 1).Range("C1:Z1")

        If cell.Value Like "?*@?*.?*" And _
           Application.WorksheetFunction.CountA(rng) > 0 Then
            Set OutMail = OutApp.CreateItem(0)

            With OutMail
                .to = cell.Value
                .Subject = "Testfile"
                .Body = "Hi " & cell.Offset(0, -1).Value

                For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                    If Trim(FileCell) <> "" Then
                        If Dir(FileCell.Value) <> "" Then
                            .Attachments.Add FileCell.Value
                        End If
                    End If
                Next FileCell

                .Send  'Or use .Display
            End With

            Set OutMail = Nothing
        End If
    Next cell

    Set OutApp = Nothing
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

https://www.rondebruin.nl/win/s1/outlook/amail6.htm