使用VBA循环账户，分别发送提醒邮件

我正在使用下面的代码来遍历电子表格中的每一行。 只要符合if条件，提醒邮件就会自动发送。 但通过这种方式，只有一个相同的电子邮件将被发送与所有电子邮件地址显示在“收件人：”。 为了隐私目的，

我希望电子邮件分别发送到不同的接收者（一次发送电子邮件给一个接收者）。 我应该如何更新循环来做到这一点？ 有什么想法吗？

Sub SendReminderMail() Dim OutLookApp As Object Dim OutLookMailItem As Object Dim iCounter As Integer Dim MailDest As String Dim NumRows As Integer Set OutLookApp = CreateObject("Outlook.Application") Set OutLookMailItem = OutLookApp.CreateItem(0) NumRows = ActiveSheet.UsedRange.Rows.Count With OutLookMailItem MailDest = "" For iCounter = 1 To NumRows If MailDest = "" And Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then MailDest = Cells(iCounter, 6).Value ElseIf MailDest <> "" And Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then MailDest = MailDest & ";" & Cells(iCounter, 6).Value End If Next iCounter .To = MailDest .CC = CC .BCC = BCC .Subject = "FYI" .Body = "Reminder: Some Message" .Send End With Set OutLookMailItem = Nothing Set OutLookApp = Nothing End Sub 

Answer 1

您只需移动创build的代码部分并将电子邮件发送到循环中。

 Sub SendReminderMail() Dim OutLookApp As Object Dim OutLookMailItem As Object Dim iCounter As Integer Dim MailDest As String Dim NumRows As Integer Set OutLookApp = CreateObject("Outlook.Application") Set OutLookMailItem = OutLookApp.CreateItem(0) NumRows = ActiveSheet.UsedRange.Rows.Count For iCounter = 1 To NumRows MailDest = "" If Cells(iCounter, 6).Offset(0, -2) = "Send Reminder" Then Set OutLookMailItem = OutLookApp.CreateItem(0) With OutLookMailItem MailDest = Cells(iCounter, 6).Value .To = MailDest .CC = CC .BCC = BCC .Subject = "FYI" .Body = "Reminder: Some Message" .Send Set OutLookMailItem = Nothing End With End If Next iCounter Set OutLookApp = Nothing End Sub