Send bulk mail using Excel VBA - vba

Question

Was working on a project which will be sending bulk mail to different people if the conditions are met.
Conditions :
Column U contains the final status (Open or WIP) (will not send if Closed no matter if current date is larger)
Column Q contains Closure date. Which when compared to current date, if less then automatic shooting mails to people.
I had tried to do with for loop but its giving shooting 4 mails with same To and CC. And not going to the next row to compare.
Thank you in advance.
Code as below:
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim StrBody As String
Dim x As Variant
Dim arr1 As Variant
Dim i As Long, r As Long
On Error Resume Next
arr1 = Worksheets("Data").Range("Q2:Q" & Range("Q" & Rows.Count).End(xlUp).row).Value
i = 1
For Each x In arr1
For r = 1 To 2
If x < Now() Then
If Sheets("Data").Worksheets("Data").Cells(i, "U").Value = "Open" 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)
With OutMail
If Worksheets("Data").Cells(i, "C").Value = "Operation_Support" And Worksheets("Data").Cells(i, "E").Value = "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

Answer 1

Solved: This will solve the problem above.
Sub Data_RoundedRectangle1_Click()
Dim OutApp As Object
Dim OutMail As Object
Dim rng As Range
For i = 2 To Cells(Rows.Count, 1).End(xlUp).row
If Cells(i, 21).Value = "Open" And Cells(i, 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("Data").Range("C1:V5").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 Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).Value = "Quality_Assurance" Then
StrBody = "Hi," & "<br>" & _
"PFB the process details which requires your attention." & "<br>" & _
"The review for this process has crossed overdue." & "<br>" & _
"Please ask the process owner to review the Process Manuals and Maps." & "<br><br><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 Cells(i, 3).Value = "Operation_Support" And Cells(i, 5).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 = "s"
.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
End If
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End If
Next i
End Sub