我有Excel VBA代码，它根据每个填充的行填充Outlook电子邮件模板中的信息。在这些行中是作为字符串保存的电子邮件地址。
当代码遇到重复的电子邮件地址时，它只会发送一封电子邮件（通常是列表中的第一封电子邮件）。我可以修改哪些内容以确保它为每个具有电子邮件地址的单元格发送电子邮件？
'**********You MUST DO THIS FIRST**********
'On the Tools menu, click References.
'In the Available References list,
' click to select the 'Microsoft Outlook XX.X Object Library check box. Click OK.
'--- Set up the Outlook objects.
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim body As String
Dim T As Integer
Dim Y As Integer
'--- Declare our global variables to be used in each subroutine.
Dim CustomerAddress As String
Dim CustomerMessage As String
Sub dayonemail()
'--- Declare our variables.
Dim X As Integer
Dim AA As Long, i As Long
Sheets(4).Select
Range("A1").Select
AA = Range("I" & Rows.Count).End(xlUp).Row
If AA >= 3 Then
'--- Sets which row to start searching for e-mail addresses and names.
X = 2
'--- Begin looping through all the e-mail addresses in column A until
' a blank cell is hit.
While ActiveWorkbook.Sheets("day1").Range("I" & X).Text <> ""
'--------------------------------------------------------------------
'--- These variables will be used to search for duplicates.
' CustomerAddress = ActiveWorkbook.Sheets("day1").Range("J" & X).Text
TempCustomerAddress = CustomerAddress
'--- Increment X until a different e-mail address is found.
While TempCustomerAddress = CustomerAddress
X = X + 1
CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X).Text
Wend
'-----------------------------------------------------------------
'--- Add the e-mail address to a global variable.
CustomerAddress = ActiveWorkbook.Sheets("day1").Range("I" & X - 1).Text
'--- Run the subroutine to send the message.
'--- This is required to prevent a name which does not resolve to
' an e-mail address from hanging the app.
On Error Resume Next
' Create the Outlook session.
Set objOutlook = CreateObject("Outlook.Application")
' Create the message.
Set objOutlookMsg = objOutlook.CreateItemFromTemplate("C:\Users\me\new.oft")
F = ActiveWorkbook.Sheets("day1").Range("B" & X - 1)
G = ActiveWorkbook.Sheets("day1").Range("E" & X - 1)
H = ActiveWorkbook.Sheets("day1").Range("Z" & X - 1)
J = ActiveWorkbook.Sheets("day1").Range("Z" & X - 1)
k = ActiveWorkbook.Sheets("day1").Range("F" & X - 1)
l = ActiveWorkbook.Sheets("day1").Range("G" & X - 1)
M = ActiveWorkbook.Sheets("day1").Range("H" & X - 1)
n = ActiveWorkbook.Sheets("day1").Range("I" & X - 1)
o = ActiveWorkbook.Sheets("day1").Range("J" & X - 1)
With objOutlookMsg
' Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(CustomerAddress)
objOutlookRecip.Type = olTo
.HTMLBody = Replace(.HTMLBody, "Field1", F)
.HTMLBody = Replace(.HTMLBody, "Field2", G)
.HTMLBody = Replace(.HTMLBody, "Field3", H)
.HTMLBody = Replace(.HTMLBody, "Field4", J)
.HTMLBody = Replace(.HTMLBody, "Field5", k)
.HTMLBody = Replace(.HTMLBody, "Field6", l)
.HTMLBody = Replace(.HTMLBody, "Field7", M)
.HTMLBody = Replace(.HTMLBody, "Field8", n)
.HTMLBody = Replace(.HTMLBody, "Field9", o)
'.Importance = olImportanceHigh 'High importance
' Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
' Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
Resume Next
End If
Next
.Send '--- Send the message.
End With
'--- Remove the message and Outlook application from memory.
Set objOutlookMsg = Nothing
Set objOutlook = Nothing
Wend
Else
End If
End Sub
答案 0 :(得分：1)
这里有一个快速重写，只是逐行移动，为该行上的每封电子邮件发送一封电子邮件。我已经省去了While循环，并将其替换为每行循环的For循环，作为范围。至少对我来说，似乎更清楚一点代码中发生了什么。
'**********You MUST DO THIS FIRST**********'On the Tools menu, click References.
'In the Available References list, click to select the 'Microsoft Outlook 9.0 Object Library check box. Click OK.
'--- Set up the Outlook objects.
Dim objOutlook As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecip As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim body As String
'--- Declare our global variables to be used in each subroutine.
Dim CustomerAddress As String
Dim CustomerMessage As String
Sub dayonemail()
'--- Declare our variables.
Dim firstRow As Integer
Dim readRow as Range
Dim CountOfRows As Long
'---determine how many rows of data we have
CountOfRows = Sheets("day1").Range("I" & Rows.Count).End(xlUp).Row
'--- Only continue if we have more than 2 rows.
If CountOfRows > 2 Then
'--- Create the outlook session outside the loop
Set objOutlook = CreateObject("Outlook.Application")
'--- Loop through all populated rows, starting at row 2 to the last row sending emails as we go
For each readRow in ActiveWorkbook.Sheets("day1").Range("I2:I" & CountOfRows).Rows
'--- email address (Column I or column number 9)
CustomerAddress = readRow.Cells(1, 9).Value
'--- Get email body parts
F = readRow.Cells(1, 2).value
G = readRow.Cells(1, 5).value
H = readRow.Cells(1, 26).value
J = readRow.Cells(1, 26).value
k = readRow.Cells(1, 6).value
l = readRow.Cells(1, 7).value
M = readRow.Cells(1, 8).value
n = readRow.Cells(1, 9).value
o = readRow.Cells(1, 10).value
'--- Create the message.
Set objOutlookMsg = objOutlook.CreateItemFromTemplate("C:\Users\me\new.oft")
With objOutlookMsg
'--- Add the To recipient(s) to the message.
Set objOutlookRecip = .Recipients.Add(CustomerAddress)
objOutlookRecip.Type = olTo
.HTMLBody = Replace(.HTMLBody, "Field1", F)
.HTMLBody = Replace(.HTMLBody, "Field2", G)
.HTMLBody = Replace(.HTMLBody, "Field3", H)
.HTMLBody = Replace(.HTMLBody, "Field4", J)
.HTMLBody = Replace(.HTMLBody, "Field5", k)
.HTMLBody = Replace(.HTMLBody, "Field6", l)
.HTMLBody = Replace(.HTMLBody, "Field7", M)
.HTMLBody = Replace(.HTMLBody, "Field8", n)
.HTMLBody = Replace(.HTMLBody, "Field9", o)
'.Importance = olImportanceHigh 'High importance
'--- Add attachments to the message.
If Not IsMissing(AttachmentPath) Then
Set objOutlookAttach = .Attachments.Add(AttachmentPath)
End If
'--- Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
If Not objOutlookRecip.Resolve Then
Resume Next
End If
Next
.Send '--- Send the message.
End With
'--- Remove the message from memory
Set objOutlookMsg = Nothing
Next readRow
'--- Get rid of the outlook application
Set objOutlook = Nothing
End If
End Sub