EXCEL VBA send dynamic emails messages based on trigger column

I am attempting to send emails to a distribution list based on a trigger column (column E). Each row that contains the word "Captured" should send an email to the address in column A. The email body for these outgoing emails should contain content in column D. Ideally I would like the Name (B) and Client (C) to dynamically appear in the Subject of the email.


The code below, fires to the correct recipients but sends the same message body (last one within the list to all email addresses).

I am in need of this for a large project so any help would be amazing!

Dim outlookapp As Object
Dim Outlookmailitem As Object
Dim Icounter As Integer
Dim maildest As String
Dim mess As String

Set outlookapp = CreateObject("outlook.application")
Set Outlookmailitem = outlookapp.CreateItem(0)

With Outlookmailitem
maildest = ""
For Icounter = 1 To WorksheetFunction.CountA(Columns(1))
If maildest = "" And Cells(Icounter, 1).Offset(0, 4) = "Captured" Then
mess = Cells(Icounter, 4).Value
maildest = Cells(Icounter, 1).Value

ElseIf maildest <> "" And Cells(Icounter, 1).Offset(0, 4) = "Captured" Then
mess = Cells(Icounter, 4).Value
maildest = maildest & ";" & Cells(Icounter, 1).Value

End If
Next Icounter

.CC = maildest
.Subject = "name and Client"
.Body = mess
.Send
End With

Set Outlookmailitem = Nothing
Set outlookapp = Nothing
End Sub

post withdrawn

reason why your receipts are dynamic but nothing else is because of this line

maildest = maildest & ";" & Cells(Icounter, 1).Value

you dont have something similar for your mess or your subject
to get subject in there you should have a variable to capture subject as well

how exactly do you want to structure your subject and your "mess"

ps why are you using

Cells(Icounter, 1).Offset(0, 4)

instead of just

Cells(Icounter, 5)

?

i've reconstructed what i think your spreadsheet looks like and added some sample code of what you could possibly do

Sub EmailTest()

    Dim outlookapp As Object 'mailapp object
    Dim Outlookmailitem As Object 'mailitem object
    Dim Icounter As Integer 'counter for loop
    Dim MailDest As String 'email destination
    Dim Mess As String 'message
    Dim Subject As String 'subject
    
    Set outlookapp = CreateObject("outlook.application")
    Set Outlookmailitem = outlookapp.CreateItem(0)
    
    With Outlookmailitem
        
        MailDest = ""
        For Icounter = 2 To WorksheetFunction.CountA(Columns(1))
            If MailDest = "" And Cells(Icounter, 5) = "Captured" Then
                Mess = Cells(Icounter, 4).Value
                MailDest = Cells(Icounter, 1).Value
                Subject = Cells(Icounter, 2).Value & " - " & Cells(Icounter, 3).Value
            
            ElseIf MailDest <> "" And Cells(Icounter, 5) = "Captured" Then
                Mess = Mess & vbNewLine & Cells(Icounter, 4).Value
                MailDest = MailDest & ";" & Cells(Icounter, 1).Value
                Subject = Subject & " | " & Cells(Icounter, 2).Value & " - " & Cells(Icounter, 3).Value
            
            End If
        Next Icounter
        
        .To = MailDest 'not sure why you were using .cc instead of .to
        .Subject = Subject
        .Body = "List of Messages" & vbNewLine & vbNewLine & Mess & vbNewLine & vbNewLine & "Yours Sincerly," & _
            vbNewLine & "McJonesy" 'change to however you want email to be displayed, use vbnewline to enter new line
        .display '.Send change to .send for automatic send, use .display when debugging
        
    End With
    
    Set Outlookmailitem = Nothing
    Set outlookapp = Nothing
    
End Sub

see if you does what you want
ps i changed .send to .display so it doesnt automatically send out emails while you are debugging

Originally Posted by mcjonesy

this is very close. I tried out your attachment, the only thing is that each email should be sent separately not in one joint email. So in your example there should be 4 separate emails. Any suggestions?

yes, essentially
you put the mailitems (.to,.subject,.body,etc) within the icounter For/Next Loop
so it generates seperate email per loop

Originally Posted by mcjonesy

I don't want to make things to complicated but can separate emails can be sent only for unique email addresses? In your example if row three and nine were both [email protected] with two different messages. Is it possible to group those messages in one email (with a blank line in between) while keeping other rows with different email addresses separate?

this is slightly more complicated
i will need to have a little think on how to do this the easiest way

how many rows of data are you expecting to run this for?
50, 1000, 1000000?

you can do capture > sent code at the same time of the email
no need to run it seperately

On unique emails
can i put a helper column in the data to count number of emails to each email address?
it would save me putting it in the code itself

also re:subject
i changed it to Subject = "Monsanto " & Cells(Icounter, 3).Value & " Application Development " & Cells(Icounter, 2).Value & " Opportunity"
however in the case there are more than one emails, how do you want subject handled?

it was a bit more complicated then i thought but no need for helper column since you change "Captured" to "sent"

Sub EmailTest()

    Dim outlookApp As Object 'mailapp object
    Dim OutlookMailItem As Object 'mailitem object
    Dim Icounter As Integer 'counter for loop
    Dim MailDest As String 'email destination
    Dim Mess As String 'message
    Dim Subject As String 'subject
    Dim j As Long 'counter for times email appears
    Dim f As Range ' Find and FindNext Range
    Dim RangeToSearch As Range 'define the range of what to search
    Dim fFirst As Range 'First range
    
    For Icounter = 2 To WorksheetFunction.CountA(Columns(1))
                                
        'reset after each email
        Set outlookApp = CreateObject("outlook.application")
        Set OutlookMailItem = outlookApp.CreateItem(0)
        MailDest = ""
        Subject = ""
        Mess = ""
        j = 0
            
        If Cells(Icounter, 5) = "Captured" Then
            
            With OutlookMailItem
                
                'determine how many times emails shows up
                j = Application.CountIf(Range("A2:A" & WorksheetFunction.CountA(Columns(1))), Cells(Icounter, 1))
                
                If j = 1 Then
                    
                    Mess = Cells(Icounter, 4).Value
                    MailDest = Cells(Icounter, 1).Value
                    Subject = "Monsanto " & Cells(Icounter, 3).Value & " Application Development " & Cells(Icounter, 2).Value & " Opportunity"
                    Cells(Icounter, 5) = "Sent"
                Else
                    
                    Set RangeToSearch = Range("A2:A" & WorksheetFunction.CountA(Columns(1))) 'define range to search
                    Set f = RangeToSearch.Find(Cells(Icounter, 1).Value, lookat:=xlPart, LookIn:=xlValues) 'set first find
                    Set fFirst = f 'set first address
                    
                    'maildest and subject stay the same
                    MailDest = Cells(f.Row, 1).Value
                    Subject = "Monsanto " & Cells(f.Row, 3).Value & " Application Development " & Cells(Icounter, 2).Value & " Opportunity"
                    
                    'define first row of message and update "To send" column
                    Mess = Cells(f.Row, 4).Value
                    Cells(Icounter, 5) = "Sent"
                    
                    Do Until f Is Nothing
                        Set f = RangeToSearch.FindNext(f) 'set next find
                        If f.Address = fFirst.Address Then Exit Do 'exit loop criteria
                        Mess = Mess & vbNewLine & Cells(f.Row, 4).Value 'update mess
                        Cells(f.Row, 5) = "Sent" 'update To Send
                    Loop
                End If
                
                .To = MailDest 'not sure why you were using .cc instead of .to
                .Subject = Subject
                .Body = "List of Messages" & vbNewLine & vbNewLine & Mess & vbNewLine & vbNewLine & "Yours Sincerly," & _
                    vbNewLine & "McJonesy" 'change to however you want email to be displayed, use vbnewline to enter new line
                .display '.Send change to .send for automatic send, use .display when debugging
            End With
            
            Set OutlookMailItem = Nothing
            Set outlookApp = Nothing
            
        End If
        
    Next Icounter
    
End Sub

few more variables involved mainly with capturing multiple lines into one email

I took your example and modified it slightly. Bug one from above is resolved. Bug two still exists.

If the enhancement from my post above isn't possible I would like to format the email body with two columns Cap and Mess. A grid would be ideal.

Thoughts? Also I would be happy to attach my excel project to these posts but it appears I am not able too.

   Sub victory()
    
    Dim outlookApp As Object 'mailapp object
    Dim OutlookMailItem As Object 'mailitem object
    Dim Icounter As Integer 'counter for loop
    Dim MailDest As String 'email destination
    Dim Mess As String 'message
    Dim cap As String 'capability
    Dim Subject As String 'subject
    Dim j As Long 'counter for times email appears
    Dim f As Range ' Find and FindNext Range
    Dim RangeToSearch As Range 'define the range of what to search
    Dim fFirst As Range 'First range
    
    For Icounter = 2 To WorksheetFunction.CountA(Columns(7))
                                
        'reset after each email
        Set outlookApp = CreateObject("outlook.application")
        Set OutlookMailItem = outlookApp.CreateItem(0)
        MailDest = ""
        Subject = ""
        Mess = ""
        cap = ""
        j = 0
            
        If Cells(Icounter, 9) = "Captured" Then
            
            With OutlookMailItem
                
                'determine how many times emails shows up
                j = Application.CountIf(Range("G2:G" & WorksheetFunction.CountA(Columns(7))), Cells(Icounter, 7))
                
                If j = 1 Then
                    
                    Mess = Cells(Icounter, 8).Value
                    MailDest = Cells(Icounter, 7).Value
                    Subject = Cells(Icounter, 2).Value & "  " & Cells(Icounter, 4).Value & " Opportunities"
                    Cells(Icounter, 9) = "Sent to CSA"
                Else
                    
                    Set RangeToSearch = Range("G2:G" & WorksheetFunction.CountA(Columns(7))) 'define range to search
                    Set f = RangeToSearch.Find(Cells(Icounter, 7).Value, lookat:=xlPart, LookIn:=xlValues) 'set first find
                    Set fFirst = f 'set first address
                    
                    'maildest and subject stay the same
                    MailDest = Cells(f.Row, 7).Value
                    Subject = "New Capability Opportunities"
                    
                    'define first row of message and update "To send" column
                    Mess = Cells(f.Row, 8).Value
                    cap = Cells(f.Row, 4).Value
                    Cells(Icounter, 9) = "Sent to CSA"
                    
                    Do Until f Is Nothing
                        Set f = RangeToSearch.FindNext(f) 'set next find
                        If f.Address = fFirst.Address Then Exit Do 'exit loop criteria
                        Mess = Mess & vbNewLine & Cells(f.Row, 8).Value 'update mess
                        cap = cap & vbNewLine & Cells(f.Row, 4).Value 'update cap
                        Cells(f.Row, 9) = "Sent to CSA" 'update To Send
                    Loop
                End If
                
                .To = MailDest 'not sure why you were using .cc instead of .to
                .Subject = Subject
                .Body = "List of Opportunities:" & vbNewLine & vbNewLine & cap & Mess & vbNewLine & vbNewLine & "Refer to spreadsheet for complete list of all opportunities!" 'change to however you want email to be displayed, use vbnewline to enter new line
                .Display '.Send change to .send for automatic send, use .display when debugging
            End With
            
            Set OutlookMailItem = Nothing
            Set outlookApp = Nothing
            
        End If
        
    Next Icounter
    
End Sub

Sorry wasnt able to look at this today
got bogged down at work

try these methods for uploading file
http://www.excelforum.com/the-water-...his-forum.html

ok i found the issues in your code

you didnt update the column references properly on every line

ie

j = Application.CountIf(Range("D2:D" & WorksheetFunction.CountA(Columns(4))), Cells(Icounter, 4))

should be

j = Application.CountIf(Range("G2:G" & WorksheetFunction.CountA(Columns(7))), Cells(Icounter, 7))

and your rangetosearch wasnt pointing to the right column

Set RangeToSearch = Range("G2:G" & WorksheetFunction.CountA(Columns(7))) 'define range to search

in turn it wasnt updating column 9 properly

so i had a chance to properly review your code
it seems you had two running variables "cap" and "mess" to change essentially one line of Body
this seems unnecessary and can lead to confusion so i combined into one

also got rid of mutliple CountA lines and replaced them with one variable that you calculate once

Sub victory()
    
    Dim outlookApp As Object 'mailapp object
    Dim OutlookMailItem As Object 'mailitem object
    Dim Icounter As Integer 'counter for loop
    Dim MailDest As String 'email destination
    Dim Mess As String 'message
    Dim Subject As String 'subject
    Dim j As Long 'counter for times email appears
    Dim lRow As Long 'last Row of table
    Dim f As Range 'range for Find and FindNext loop
    Dim RangeToSearch As Range 'define the range of what to search
    Dim fFirst As Range 'fariable for first found range
    
    'use this to determine last row once instead of doing it multiple times within the loop
    lRow = WorksheetFunction.CountA(Columns(7))
    
    For Icounter = 2 To lRow
                                
        'reset after each email
        Set outlookApp = CreateObject("outlook.application")
        Set OutlookMailItem = outlookApp.CreateItem(0)
        MailDest = ""
        Subject = ""
        Mess = ""
        j = 0
            
        If Cells(Icounter, 9) = "Captured" Then
            
            With OutlookMailItem
                
                'determine how many times emails with "captured" shows up
                j = Application.CountIfs(Range("G2:G" & lRow), Cells(Icounter, 7), Range("I2:I" & lRow), Cells(Icounter, 9))
                
                If j = 1 Then
                    
                    Mess = Cells(Icounter, 4).Value & " - " & Cells(Icounter, 8).Value ' combined Cap and Mess into one instead of having two variables to manage
                    MailDest = Cells(Icounter, 7).Value
                    Subject = Cells(Icounter, 2).Value & "  " & Cells(Icounter, 4).Value & " Opportunities"
                    Cells(Icounter, 9) = "Sent to CSA"
                
                Else
                    
                    Set RangeToSearch = Range("G2:G" & lRow) 'define range to search
                    Set f = RangeToSearch.Find(Cells(Icounter, 7).Value, lookat:=xlPart, LookIn:=xlValues) 'set first find
                    Set fFirst = f 'set first address
                    
                    'maildest and subject stay the same
                    MailDest = Cells(f.Row, 7).Value
                    Subject = "New Capability Opportunities"
                    
                    'define first row of message and update "To send" column
                    Mess = Cells(f.Row, 4).Value & " - " & Cells(f.Row, 8).Value
                    
                    Cells(f.Row, 9) = "Sent to CSA"
                    
                    Do Until f Is Nothing
                        Set f = RangeToSearch.FindNext(f) 'set next find
                        If f.Address = fFirst.Address Then Exit Do 'exit loop criteria
                        
                        If Cells(f.Row, 9) = "Captured" Then
                            Mess = Mess & vbNewLine & Cells(f.Row, 4).Value & " - " & Cells(f.Row, 8).Value 'update mess
                            Cells(f.Row, 9) = "Sent to CSA" 'update To Send
                        End If
                    Loop
                End If
                
                .To = MailDest 'not sure why you were using .cc instead of .to
                .Subject = Subject
                .Body = "List of Opportunities:" & _
                    vbNewLine & vbNewLine & Mess & vbNewLine & vbNewLine & _
                    "Refer to spreadsheet for complete list of all opportunities!"
                    'change to however you want email to be displayed, use vbnewline to enter new line
                    
                .Display '.Send change to .send for automatic send, use .display when debugging
            End With
            
            Set OutlookMailItem = Nothing
            Set outlookApp = Nothing
            
        End If
        
    Next Icounter
    
End Sub

attached new file
hopefully this one works properly now

not a problem
glad to have helped


If that takes care of your original question, please select Thread Tools from the menu link above and mark this thread as SOLVED. Thanks.