CODEWITHSUNDEEP
excelvba7
PowerAppsNewbie
PowerAppsNewbie

Reputation: 27

How to send email to specific recipients if corresponding cell contains the word " expired"?

I have a list of email address but I need to send an email to only the individuals that have "expired" in their corresponding cell. On button click, it is opening multiple outlook windows.

This is what I have so far:

Private Sub CommandButton1_Click()
Dim c As Range
For Each c In Range("F5:F42")
    If c.Value2 = "Expired" Then Call Mail_small_Text_Outlook(c.Offset(0, -3).Value2)
Next c
End Sub
Sub Mail_small_Text_Outlook(emailAddress As String)

    Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
Set ws = Sheets("Sheet1")
 Set Rng = ws.Range(ws.Range("A1"), ws.Range("A" & Rows.Count).End(xlUp))
  
    For Each cell In Rng
           
    If cell.Value2 = "Expired" Then
      SendTo = SendTo & cell.Value & ";"
    End If
   Next
    
    strbody = "Hello," & vbNewLine & vbNewLine & _
              "You are receiving this email because your Wastewater Pathogens (Annual) is now expired or will expire within the next 30 days. Please sign up for the next available class in LMS. If you are unable to sign up in LMS, please contact Christa Scott." & vbNewLine & _
              "Thank you and have a nice day."

    On Error Resume Next
    With OutMail
        .To = SendTo
        .CC = ""
        .BCC = ""
        .Subject = "Expired Hazmat Right-to-Know Training - " & Date
        .Body = strbody

        .Display 'or .Send to automatically send email.
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Upvotes: 0

Views: 42

Answers (1)

norie
norie

Reputation: 9857

To run the code from a command button call it once, and to check for 'expired' in column F use cell.Offset(,5).Value2.

Option Explicit

Private Sub CommandButton1_Click()
    Call Mail_small_Text_Outlook
End Sub

Sub Mail_small_Text_Outlook()
Dim ws As Worksheet
Dim rng As Range
Dim cell As Range
Dim OutApp As Object
Dim OutMail As Object
Dim strSendTo As String
Dim strBody As String

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

    Set ws = Sheets("Sheet1")
    Set rng = ws.Range(ws.Range("A1"), ws.Range("A" & Rows.Count).End(xlUp))

    For Each cell In rng
        If cell.Offset(, 5).Value2 = "Expired" Then
            strSendTo = strSendTo & cell.Value & ";"
        End If
    Next

    strBody = "Hello," & vbNewLine & vbNewLine & _
              "You are receiving this email because your Wastewater Pathogens (Annual) is now expired or will expire within the next 30 days. Please sign up for the next available class in LMS. If you are unable to sign up in LMS, please contact Christa Scott." & vbNewLine & _
              "Thank you and have a nice day."

    On Error Resume Next
    With OutMail
        .To = strSendTo
        .CC = ""
        .BCC = ""
        .Subject = "Expired Hazmat Right-to-Know Training - " & Date
        .Body = strBody

        .Display    'or .Send to automatically send email.
    End With
    On Error GoTo 0

    Set OutMail = Nothing
    Set OutApp = Nothing

End Sub

Upvotes: 1

Related Questions