VBA Macro to send email of row items based on criteria in last column

[tbraun]

Hi,

I am trying to send just one email using the below macro of all items in a list. Instead, it is sending multiple emails, one for each item in a certain comlumn that does not equal (<>) "Completed"

Public Subject As String
Public ToEmailID As String
Public EmailBody As String
Public ToName As String



Sub SendEmailUsingOutlook(Subject As String, ToEmailID As String, EmailBody As String)

Dim OlApp As New Outlook.Application
Dim myNameSp As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myExplorer As Outlook.Explorer
Dim NewMail As Outlook.MailItem
Dim OutOpen As Boolean

' Check to see if there's an explorer window open
' If not then open up a new one
OutOpen = True
Set myExplorer = OlApp.ActiveExplorer
If TypeName(myExplorer) = "Nothing" Then
OutOpen = False
Set myNameSp = OlApp.GetNamespace("MAPI")
Set myInbox = myNameSp.GetDefaultFolder(olFolderInbox)
Set myExplorer = myInbox.GetExplorer
End If
'myExplorer.Display ' You don't have to show Outlook to use it

' Create a new mail message item.
Set NewMail = OlApp.CreateItem(olMailItem)
With NewMail
'.Display ' You don't have to show the e-mail to send it
.Subject = Subject
.To = ToEmailID
.Body = EmailBody

End With

NewMail.Send
If Not OutOpen Then OlApp.Quit

'Release memory.
Set OlApp = Nothing
Set myNameSp = Nothing
Set myInbox = Nothing
Set myExplorer = Nothing
Set NewMail = Nothing

End Sub


Sub auto_open()

Dim iRow
iRow = 9
Sheets("Sheet1").Activate

On Error Resume Next

While Range("A" & iRow).Value <> ""

If Range("J" & iRow).Value <> "Completed" Then

ToName = "Hi,"
ToEmailID = "xxxxxx@gmail.com"
CCEmailID = "xxxxxx@gmail.com"
Subject = "FAC Policy Push ME Close " & " - " & Range("E" & iRow).Value

EmailBody = "Hi," & vbNewLine & vbNewLine & "Please add the following to the FRS push table for the close period of " _
& Range("E" & iRow).Value & vbNewLine & vbNewLine & Range("A" & iRow).Value & " -- " & Range("B" & iRow).Value & "-" & Range("C" & iRow).Value & " -- " & Range("D" & iRow).Value


Call SendEmailUsingOutlook(Subject, ToEmailID, EmailBody)


End If

iRow = iRow + 1

Wend
Sheet1.Label1.Caption = CStr(VBA.Date)
ThisWorkbook.Save


End Sub