我有一份客户电子表格,其中列出了客户姓名、电子邮件地址、联系人和管理员。 我希望能够使用列出客户的行中的数据向每个客户发送单独的电子邮件。
我已经编写了一些 VBA(从其他人那里获得的部分),但它试图将所有电子邮件地址添加到“收件人”字段,并且每个其他字段都提取所有数据而不是相关行。
我对 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
最佳答案
回答您的问题:
我认为您只看到一封电子邮件的原因是您只创建了一个 OutMail 对象。如果要循环,则需要先设置 object = Nothing,然后才能创建新对象:
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
一些一般建议:
将代码分成更小的部分可以帮助使事情更容易修复和阅读。它还使其对于本项目和 future 的项目更具可重用性。 我添加此反馈是因为它还可以更轻松地在此处回答问题。
例如:
检查 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 发送电子邮件
关于excel - 使用 VBA 使用 Excel 单元格中的数据发送多封电子邮件,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/52350375/