Enviar email em massa usando o Excel VBA

Estava trabalhando em um projeto que enviaria emails em massa para pessoas diferentes se as condições fossem atendidas.

Condições:

• A coluna U contém o status final (Aberto ou WIP) (não será enviado se Fechado, não importa se a data atual for maior)
• A coluna Q contém a data de encerramento. Que quando comparado à data atual, se for menor, dispara automaticamente no correio para as pessoas.

Eu tentei fazer com loop, mas está dando tiro 4 e-mails com o mesmo para e CC. E não indo para a próxima linha para comparar.

Comparação de células V2 com Q2, depois próximo loop V3 com Q3 e, na mesma mão, verifique se a célula U2 está "Aberta"

Agradeço antecipadamente.

Código como abaixo:

Sub Data_RoundedRectangle1_Click()

Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String



On Error Resume Next

For i = 1 to 4

If Sheets("Data").Range("U2:U6").Value2 = "Open" Or     Sheets("Data").Range("U2:U6").Value2 = "WIP" And (CDate(Cells(2, 17).Value) <     Now()) Then



        Set rng = Nothing
        On Error Resume Next
        'Only the visible cells in the selection
        Set rng = Selection.SpecialCells(xlCellTypeVisible)
        'You can also use a fixed range if you want
        Set rng = Sheets("Checklist").Range("A2:B25").SpecialCells(xlCellTypeVisible)
        On Error GoTo 0


        With Application
        .EnableEvents = False
        .ScreenUpdating = False
        End With

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

        On Error Resume Next

With OutMail


        If Worksheets("Data").Cells(i, "C").Value2 = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value2 = "Quality_Assurance" Then


     StrBody = "Hi," & "<br>" & _


.To = "a"

.CC = "b"
.BCC = ""
.Subject = ""
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send

ElseIf Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "Analytics" Then

StrBody = "Hi," & "<br>" & _
      "PFB the process details which requires your attention." & "<br>" & _
      "The review for this process has crossed over due." & "<br>" & _
      "Please ask the process owner to review the Process Manuals and Maps."     & "<br><br><br>"

.To = "c"

.CC = "d"
.BCC = ""
.Subject = "Process Manual and Maps Review is Overdue"
.HTMLBody = StrBody & RangetoHTML(rng)
.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:\test.txt")
.Display
'.Send

End If

    End With

    i = i + 1
    Exit For

    End If
End If

Next r

On Error GoTo 0

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing

Next x
End Sub

Eu acho que é por causa do seu loop

For i = 1 to 4

Mas você nunca faz referência i, por isso está fazendo tudo quatro vezes. Você deve usá-lo assim -

If Sheets("Data").cells(21,1+i).Value2 = "Open" Or Sheets("Data").cells(21,1+i).Value2 = "WIP" And ...

Não tenho muita certeza a que ifse refere a segunda parte , mas você entendeu.