Send Email Based on Cell Value

Hi everyone,

The below VBA code is set to send an email to a recipient (in column J) whenever a "Yes" is entered in column "I:I".
The issue is that if I put "Yes" in I3 and there is already a "Yes" in I2, it will send two emails for the two lines. If I now put "Yes" in I4, it will send an email to I2, I3 AND I4.

I'd like my code to only send an email to the line I am putting a "Yes" in.

Thanks!

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

If Target.Cells.Count > 1 Then Exit Sub

If (Not Intersect(Target, Range("I:I")) Is Nothing) And (Target.Value = "Yes") Then
   Call Mail_small_Text_Outlook
End If

End Sub

Sub Mail_small_Text_Outlook()

   Dim xOutApp As Object
   Dim xOutMail As Object
   Dim xOutMsg As String
   Dim xRg As Range
   Dim xCell As Range
   Dim I As Long
   Dim xRows As Long
   Dim xCols As Long
   Dim xVal As String
   Set xRg = Range("I:I")
   If xRg Is Nothing Then Exit Sub
   xRows = xRg.Rows.Count
   xCols = xRg.Columns.Count
   For I = 1 To xRows
      Set xCell = xRg(I, xCols)
      If xCell.Value = "Yes" Then
         Set xOutApp = CreateObject("Outlook.Application")
         Set xOutMail = xOutApp.CreateItem(0)
         xOutMsg = "Hi " & xCell.Offset(0, -6).Text & ", <br/> <br/> "The" <b>" & xCell.Offset(0, -5).Text & "</b> has been completed. <br/> <br/> Thank you."
         With xOutMail
            .To = xCell.Offset(0, 1).Text
            .Subject = " Product" & xCell.Offset(0, -5).Text & " has been completed"
            .CC = ""
            .HTMLBody = xOutMsg
            .Send
         End With
         On Error GoTo 0
         Set xOutMail = Nothing
         Set xOutApp = Nothing
      End If
   Next
   
End Sub

Moderator's note: Please take the time to review our rules. There aren't many, and they are all important. Rule #2 requires code tags. I have added them for you this time because you are a new member. I have also added indentation because the undindented code was nearly unreadable. --6StringJazzer

Your post does not comply with Rule 2 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Click on Edit to open your thread, then highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

Your problem is that wile a worksheet change event is triggering the call to mail_small_text, that sub is looping through all of column I to decide who to email. You need to pass a range "Intersect(Target, Range("I:I"))" to the sub, and then only loop through that.

Welcome to the Forum M5B!

I added code tags for you, plus indentation. However, the code does not compile. There is an error on the line in red due to unbalanced quotes.

I correct that error and made the change you are asking for, but I cannot test it without your file.

The strategy is to make xCell an argument to the Sub since Worksheet_Change already knows which cell changed. Then you no longer need the loop to check every cell for "Yes".

Private Sub Worksheet_Change(ByVal Target As Range)

   If Target.Cells.Count > 1 Then Exit Sub
   
   If (Not Intersect(Target, Range("I:I")) Is Nothing) And (Target.Value = "Yes") Then
      Mail_small_Text_Outlook xCell:=Target
   End If

End Sub

Sub Mail_small_Text_Outlook(xCell As Range)

   Dim xOutApp As Object
   Dim xOutMail As Object
   Dim xOutMsg As String
   Dim xRg As Range
   Dim I As Long
   Dim xRows As Long
   Dim xCols As Long
   Dim xVal As String
   Set xRg = Range("I:I")
   If xRg Is Nothing Then Exit Sub
   xRows = xRg.Rows.Count
   xCols = xRg.Columns.Count
   Set xOutApp = CreateObject("Outlook.Application")
   Set xOutMail = xOutApp.CreateItem(0)
   xOutMsg = "Hi " & xCell.Offset(0, -6).Text & ", <br/> <br/>The <b>" & xCell.Offset(0, -5).Text & "</b> has been completed. <br/> <br/> Thank you."
   With xOutMail
      .To = xCell.Offset(0, 1).Text
      .Subject = " Product" & xCell.Offset(0, -5).Text & " has been completed"
      .CC = ""
      .HTMLBody = xOutMsg
      .Send
   End With
   On Error GoTo 0
   Set xOutMail = Nothing
   Set xOutApp = Nothing
   
End Sub