使用VBA使用Excel单元格中的数据发送多封电子邮件

时间：2018-09-16 02:05:07

标签： excel vba email outlook

我有一个客户电子表格，其中列出了客户名称，电子邮件地址，联系人和管理员。 我希望能够使用客户端列出的行中的数据向每个客户端发送一封单独​​的电子邮件。

我已经编写了一些VBA（部分内容是从其他人那里获得的），但它正在尝试将所有电子邮件地址添加到to字段，而其他每个字段都在提取所有数据，而不是相关行。 / p>

我对VBA知识还很陌生，将不胜感激。

我该如何使用每个列出的客户行中的信息来为每个客户起草单个电子邮件。

示例数据：

B列的客户名称从第3行开始

C列的电子邮件地址从第3行开始

E列的联系人姓名从第3行开始

G列从第3行开始具有管理员名称

这是VBA：

    Option Explicit

Sub AlexsEmailSender()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim lngLastRow  As Long
    Dim rngMyCell   As Range
    Dim objEmailTo  As Object
    Dim strEmailTo  As String
    Dim objCCTo     As Object
    Dim strCCTo     As String
    Dim objContact As Object
    Dim strContact As String
    Dim objAdmin As Object
    Dim strAdmin As String
    Dim strbody     As String
    Dim objClient As Object
    Dim strClient As String
    Dim strToday As Date
    strToday = Date
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

     'Make sure emails are unique
    Set objEmailTo = CreateObject("Scripting.Dictionary")

    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row

    For Each rngMyCell In Worksheets("Sheet1").Range("C3:C" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objEmailTo.Exists(CStr(rngMyCell)) = False Then
                objEmailTo.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell

    strEmailTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objEmailTo.Items)), ";")

     'Make sure cc emails are unique
    Set objCCTo = CreateObject("Scripting.Dictionary")

    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp).Row

    For Each rngMyCell In Worksheets("Sheet1").Range("D3:D" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objCCTo.Exists(CStr(rngMyCell)) = False Then
                objCCTo.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell

    strCCTo = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objCCTo.Items)), ";")

    'Make sure contacts are unique
    Set objContact = CreateObject("Scripting.Dictionary")

    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "E").End(xlUp).Row

    For Each rngMyCell In Worksheets("Sheet1").Range("E3:E" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objContact.Exists(CStr(rngMyCell)) = False Then
                objContact.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell

    strContact = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objContact.Items)), ";")

    'Make sure admins are unique
    Set objAdmin = CreateObject("Scripting.Dictionary")

    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "G").End(xlUp).Row

    For Each rngMyCell In Worksheets("Sheet1").Range("G3:G" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objAdmin.Exists(CStr(rngMyCell)) = False Then
                objAdmin.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell

    strAdmin = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objAdmin.Items)), ";")

    'Make sure clients are unique
    Set objClient = CreateObject("Scripting.Dictionary")

    lngLastRow = Worksheets("Sheet1").Cells(Rows.Count, "B").End(xlUp).Row

    For Each rngMyCell In Worksheets("Sheet1").Range("B3:B" & lngLastRow)
        If Len(rngMyCell) > 0 Then
            If objClient.Exists(CStr(rngMyCell)) = False Then
                objClient.Add CStr(rngMyCell), rngMyCell
            End If
        End If
    Next rngMyCell

    strClient = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(objClient.Items)), ";")

    Application.ScreenUpdating = True
    strbody = "Dear " & strContact & "," & vbNewLine & vbNewLine & _
    "Say Hello World!" & vbNewLine & vbNewLine & _
    "Kind Regards," & vbNewLine & _
    "Mr A Nother"

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
            With OutMail
                    .To = strEmailTo
                    .CC = strCCTo
                    .BCC = ""
                    .Subject = strToday & " - Agreement"
                    .Body = strbody
                    '.Attachments.Add
                    .Display
             End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

3 个答案:

答案 0 :(得分：2)

回答您的问题：

我认为您只看到一封电子邮件的原因是因为您仅创建了一个OutMail对象。如果要循环，则需要先设置object = none，然后才能创建一个新对象：

Set OutMail = Nothing

看起来您正在创建一个字典，其中将所有电子邮件都一起推送到了电子邮件字段中，将名称一起推送了等等。您需要一种循环浏览要发送的电子邮件的方法。您可以创建字典数组，创建对象集合或在保留数据的范围内循环。在这种情况下，循环遍历一个范围听起来最简单。

伪代码/代码如下：

'instantiate the outlook object. Use:
Set OutApp = CreateObject("Outlook.Application")

'Create your array of dictionaries or return a range with the data
'Let's call it listOfEmails

For each email in listOfEmails:

    'instantiate the mail object. Use:
    Set OutMail = OutApp.CreateItem(0)

    'The block that creates the email:
    With OutMail
        .To = strEmailTo
        .CC = strCCTo
        .BCC = ""
        .Subject = strToday & " - Agreement"
        .Body = strbody
        '.Attachments.Add
        .Display
     End With

    'destroy the object when you are done with that particular email
    Set OutMail = Nothing

Next email


Set OutApp = Nothing

一些一般建议：

将代码分成较小的部分可以使事情更易于修复和阅读。它还使该项目和将来的项目都可以重用。 我之所以加入此反馈，是因为它也使此处的问题更容易回答。

例如：

检查Outlook是否打开的功能：

Function isOutlookOpen() As Boolean
'returns true or false if Outlook is open

    Dim OutApp As Object

    On Error Resume Next
    Set OutApp = CreateObject("Outlook.Application")

    If OutApp Is Nothing Then
        isOutlookOpen = False
    Else: isOutlookOpen = True
    End If
    On Error GoTo 0

End Function

一个用于发送电子邮件的子例程，您可以从另一个子文件夹中调用该电子邮件：

Sub sendEmail(ByVal recTO As String, ByVal subjectContent As String, ByVal bodyContent As String)

    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = recTO
        '.CC = ""
        '.BCC = ""
        .subject = subjectContent
        .body = bodyContent '.HTMLBody
        .display
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

返回数据范围的函数：

Function dataRange() As Range
'Returns the range where the data is kept

    Dim ws As Worksheet
    Dim dataRng As Range
    Dim lastRow As Integer
    Dim rng As Range

    Set ws = Workbooks("outlookEmail.xlsm").Sheets("dataSheetName")
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row

    'still select where the data should go if the data range is empty
    If lastRow = 2 Then
    lastRow = lastRow + 1
    End If

    Set dataRange = Range("B3", "G" & lastRow)

End Function

将所有内容组合在一起的子例程：

Sub main()
'This sub does more than one thing, but I'm asuming it's extremely custom ans still relatively short

    Dim data As Range
    Dim subj As String
    Dim recEmail As String
    Dim body As String
    Dim Row As Range

    'check if data exists. Exit the sub if there's nothing
    Set data = dataRange
    If dataRange.Cells(1, 1).Value = "" Then
    MsgBox "Data is empty"
    Exit Sub
    End If

    'Loop through the data and send the email.
    For Each Row In data.Rows
        'Row is still a range object, so you can access the ranges inside of it like you normally would

        recEmail = Row.Cells(1, 2).Value

        If recEmail <> "" Then 'if the email is not blank, send the email
            subj = Format(Date, "mm.dd.yy") & " - Agreement"
            body = "Dear " & Row.Cells(1, 4).Value & "," & vbNewLine & vbNewLine & _
                "Say Hello World!" & vbNewLine & vbNewLine & _
                "Kind Regards," & vbNewLine & _
                "Mr A Nother"

            Call sendEmail(recEmail, subj, body)
        End If
    Next Row

End Sub

非常重要：

感谢Ron De Bruin教会我所有有关使用Excel VBA中的代码从Outlook发送电子邮件的信息

答案 1 :(得分：0)

首先，添加

显式选项

所有代码上方。 然后更正错误。 然后： https://stackoverflow.com/help/mcve

答案 2 :(得分：0)

您要使用Excel VBA实现Outlook邮件传递吗？ 如果是这样，您可以使用以下方法获取范围内的电子邮件地址。

您不会那么麻烦。您可以执行更简单的代码。 

        Sub Send_Email()
        Dim rng As Range
        For Each rng In Range("C1:C4")
                   Call mymacro(rng)
        Next rng
    End Sub
 Private Sub mymacro(rng As Range)
        Dim OutApp As Object
        Dim OutMail As Object
        Dim MailBody As String
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        MailBody = "hello"
        On Error Resume Next
        With OutMail
            .To = rng.Value
            .CC = ""
            .BCC = ""
            .Subject = Sheet1.Cells(rng.Row, 1).Value
            .Body = Sheet1.Cells(rng.Row, 2).Value
            .Display
            '.Send
        End With
        On Error GoTo 0
        Set xOutMail = Nothing
        Set xOutApp = Nothing
    End Sub

我使用mymacro方法创建一条消息并发送。

我遍历电子邮件地址（“ C1：C4”）。然后调用mymacro方法将电子邮件发送到该地址。

相关问题
最新问题