Use VBA to loop through account and send out reminder email separately - vba

Question

I am using the following code to loop through each row in the spreadsheet. whenever it meets the if condition, the reminder email will be automatically sent. But in this way, only one same email will be sent with all email address show in "To:". For privacy purpose,
I want the email to be sent to different receiver individually (send the email to one receiver a time). How should I update the loop to do this? Any thoughts?
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

You just need to move the part of the code the creates and sends the email into the loop.
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