• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

need VB code to send email message based upon sheet criteria

T

Tome9499

New Member
Greetings,


I have a rather elaborate workbook that tracks client satisfaction surveys. My support managers need to follow up on each survey with negative responses. I need a block of code that will do the following upon closing the workbook:


1) search Column "N" for any rows that do NOT contain values of either "Complete" or "Expired"


2) send email to the assigned manager designated in column "J". The data in column "J" is a user mnemonic (ex. JSMITH), so the formula will have to link to an outside dataset


sheet = "Managers" $E$1:$F$13

Mgr Mnemonic = Column "E

Email = Column "F"


Any help would be greatly appreciated.


Thanks,


Tom
 
How's this look? Note that I visited Ron's site for ideas on sending email via VBA.

http://www.rondebruin.nl/tips.htm

[pre]
Code: 
Sub CheckList()
Dim LastRow As Integer
Dim MyName As String
Dim MyEmail As String
Dim OutApp As Object
Dim OutMail As Object

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

LastRow = Range("N65536").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, "N").Value <> "Complete" And Cells(i, "N").Value <> "Expired" Then
MyName = Cells(i, "J").Value
MyEmail = WorksheetFunction.VLookup(MyValue, Worksheets("Managers").Range("E1:F13"), 2, False)

'=====
'This block of code written by Ron de Bruin, copied from
'http://msdn.microsoft.com/en-us/library/ff458119(office.11).aspx#odc_office_UseExcelObjectModeltoSendMail_Introduction

On Error Resume Next
' Change the body and subject in the macro before you run it.
With OutMail
.To = MyEmail
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.Body = "Hello World!"
'You're not sending an attachment, so I commented this out
'.Attachments.Add ActiveWorkbook.FullName
' You can add other files by uncommenting the following line.
'.Attachments.Add ("C:test.txt")
' In place of the following statement, you can use ".Display" to
' display the mail.
.Send
End With
On Error GoTo 0

'=======
End If
Next i
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
[/pre]
 
Hi Luke,


Thanks for the help. I was able to get the code working as a macro using the adjustments below. The problem I am having is that The email that generates only lists the last manager's email address in the To: field. I need all managers to list in the To: field. The other possible complication is that the same manager may be on the list multiple times. I only need a single instance of each qualifying email address to display in the To: field.

[pre]
Code: 
Sub Mail_small_Text_Outlook()

Sheet3.Activate

' Is working in Office 2000-2010
Dim LastRow As Integer
Dim MyName As String
Dim MyEmail As String

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

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

'///////////////////////////////////////////////////////

LastRow = Sheet3.Range("N65536").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, "N").Value <> "Complete" And Cells(i, "N").Value <> "Expired" Then
MyName = Cells(i, "J").Value
MyEmail = WorksheetFunction.VLookup(MyName, Worksheets("Managers").Range("E1:F13"), 2, False)
On Error Resume Next

'///////////////////////////////////////////////////////

strbody = "Greetings, " & vbNewLine & vbNewLine & _
"This automated message is a reminder that you have new or incomplete negative survey responses requiring your action on the Follow-Up Needed Workbook. You can access the Follow-Up Needed workbook at:" & vbNewLine & _
"http://intranet.picis.com/ClientOps/ServiceOps/surveys/Shared%20Documents/Forms/AllItems.aspx?RootFolder=%2fClientOps%2fServiceOps%2fsurveys%2fShared%20Documents%2fSurvey%20Unsatisfied%20Response%20Process&FolderCTID=&View=%7b1D1AE1BA%2d8EDD%2d461E%2dB74B%2d7AF4BBB4C8AF%7d." & vbNewLine & vbNewLine & _
"Regards," & vbNewLine & vbNewLine & _
"Tom Elmer"

On Error Resume Next
With OutMail

'///////////////////////////////////////////////////////

.To = MyEmail
.CC = ""
.BCC = ""
.Subject = "Follow-Up Needed Worksheet: Incomplete Follow-Up Opportunities"
.Body = strbody
.Display   'or use .Send
End With
On Error GoTo 0

End If
Next i

'///////////////////////////////////////////////////////

Set OutMail = Nothing
Set OutApp = Nothing

End Sub
[/pre]
 
Based on your original post, there was only one manager name per mnemonic. Is this not the case? Or are multiple columns/rows being used? This will be key for determining how to proceed. It sounds like we'll need to do some sort of concatenation operation...


The latter "problem" is really a non-issue as Outlook will not send duplicate email. E.g., if you send an email with this in the To field:

myemail@yahoo.com; myemail@yahoo.com


It will still only send one email to the address myemail@yahoo.com
 
Hi Luke,


There is on't a single email associated with each manager mnemonic. What I need is for email address of each of the managers with incomplete entries to appear in the To field of the email. Right now only the last manager's email address appears in the To field.


It's kind of neat to watch, actually. The new email message is created, and then all the available names (which meet the criteria set) rapidly cycle in the To field like a slot machine. The email that is finally displayed is the one which appears last on my spreadsheet. Neat though it is, Ideally, I'd like each qualifying manager's email address to appear seperated by a semicolon ";"


I cannot attach a file, but below is a CSV sample of the data set.


SR Number,Site,Account Name,Product,First Name,Last Name,Phone,Contact Email,SR Assigned To,Manager,Survey Submit Time,Initial Call Date,Completed Date,Followup Status

1-63879671,FAHC,Site1,Prod1,Sample,User,5551212,SampleUser@mail.com,JGALLANT,JBURKE,2/20/2012 15:39,2/22/2012 17:08,2/22/2012 17:08,Complete

1-65159781,FAHC,Site1,Prod2,Sample,User,5551212,SampleUser@mail.com,KBOWMAN,JCATURANO,2/20/2012 15:42,,,New

1-65184015,CFNI,Site2,Prod2,Sample,User,5551212,SampleUser@mail.com,MPOLLEYS,JBURKE,2/21/2012 10:24,2/22/2012 17:08,2/22/2012 17:08,Complete

1-64538219,KENN.UMCCH,Site3,Prod3,Sample,User,5551212,SampleUser@mail.com,LKOSAPHANDHU,FJIFFREY,2/23/2012 13:22,,,New

1-64538930,SAHE.MJUH,Site4,Prod2,Sample,User,5551212,SampleUser@mail.com,AJENKINS,JBURKE,2/23/2012 16:49,2/24/2012 16:43,2/27/2012 12:01,Complete

1-62583165,WVUH.CH,Site5,Prod3,Sample,User,5551212,SampleUser@mail.com,SCURTIS,VSANTOS,2/27/2012 9:28,,,New

1-65159781,FAHC,Site1,Prod2,Sample,User,5551212,SampleUser@mail.com,KBOWMAN,JCATURANO,2/20/2012 15:42,,,Expired

1-62583165,WVUH.CH,Site5,Prod3,Sample,User,5551212,SampleUser@mail.com,SCURTIS,VSANTOS,2/27/2012 9:28,,,Called Client
 
Hmm, I think your CSV data got all messed up, but based on your description of what you see and what you want, I think I know what's going on. Right now, the code loops through everything and creates 1 email per name. It really needs to loop through all the names first, AND THEN create the email. How's this look?

[pre]
Code: 
Sub Mail_small_Text_Outlook()

Sheet3.Activate

' Is working in Office 2000-2010
Dim LastRow As Integer
Dim MyName As String
Dim MyEmail As String

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

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

'///////////////////////////////////////////////////////

LastRow = Sheet3.Range("N65536").End(xlUp).Row
For i = 2 To LastRow
If Cells(i, "N").Value <> "Complete" And Cells(i, "N").Value <> "Expired" Then
MyName = Cells(i, "J").Value
MyEmail = MyEmail & "; " & WorksheetFunction.VLookup(MyName, Worksheets("Managers").Range("E1:F13"), 2, False)
End If
Next i

'///////////////////////////////////////////////////////

strbody = "Greetings, " & vbNewLine & vbNewLine & _
"This automated message is a reminder that you have new or incomplete negative survey responses requiring your action on the Follow-Up Needed Workbook. You can access the Follow-Up Needed workbook at:" & vbNewLine & _
"http://intranet.picis.com/ClientOps/ServiceOps/surveys/Shared%20Documents/Forms/AllItems.aspx?RootFolder=%2fClientOps%2fServiceOps%2fsurveys%2fShared%20Documents%2fSurvey%20Unsatisfied%20Response%20Process&FolderCTID=&View=%7b1D1AE1BA%2d8EDD%2d461E%2dB74B%2d7AF4BBB4C8AF%7d." & vbNewLine & vbNewLine & _
"Regards," & vbNewLine & vbNewLine & _
"Tom Elmer"

On Error Resume Next
With OutMail

'///////////////////////////////////////////////////////

.To = MyEmail
.CC = ""
.BCC = ""
.Subject = "Follow-Up Needed Worksheet: Incomplete Follow-Up Opportunities"
.Body = strbody
.Display   'or use .Send
End With
On Error GoTo 0

'///////////////////////////////////////////////////////

Set OutMail = Nothing
Set OutApp = Nothing

End Sub
[/pre]
 
Hi Tom and Luke;

Luke I see is providing very thorough help, but would this code snippet be of any value to incorporate?


Luke, you said Outlook ignores duplicate email addresses, but if there might be any reason to eliminate duplicates, you can use the following code to do so. One minor reason might be that if the email headers list the duplicates even though Outlook will only send one copy to each recipient, it could be a cosmetic thing. Otherwise, I admit it would probably be unnecessary complexity to bother eliminating them.


Start by putting your email addresses in an array. You could either add them to the array one at a time, or assign a variant to a range of cell's values, or assign a variant to a Worksheet.Evaluate() array formula that uses conditions to collect the email addresses needed. Have the formula return a boolean for any array positions that should be ignored (i.e. don't meet conditions).

[pre]
Code: 
' e.g.
a = [{"bob@shirley.com","shirley@bob.com",FALSE,"bob@shirley.com"}]
MailTo = OutlookEmailAddresses(a)
' MailTo will now equal "bob@shirley.com; shirley@bob.com"

Function OutlookEmailAddresses(EmailArray As Variant) As String
OutlookEmailAddresses = Join(DupelessArray(EmailArray), "; ")
End Function

' DupelessArray: Removes duplicate simple data types from array
Function DupelessArray(a As Variant) As Variant
Dim c As Collection, i As Long, lb As Long, vtype As Long
Set c = New Collection
lb = LBound(a)
On Error Resume Next ' Ignore errors from duplicate keys
For i = lb To UBound(a)
vt = VarType(a(i))
Select Case True
Case _
IsObject(a(i)), _
vt <= vbNull, _
vt >= vbObject And vt <= vbError, _
vt >= vbVariant And vt <= vbDataObject, _
vt >= vbUserDefinedType
' Complex data type; add but don't try to remove duplicates
c.Add a(i)
Case vt = vbBoolean ' skip booleans
Case Else
' Simple data type; add and key to remove duplicates
c.Add a(i), CStr(vt) & ";" & CStr(a(i))
End Select
Next i
On Error GoTo 0
DupelessArray = ArrayFromCollection(c, lb)
Set c = Nothing
End Function

Function ArrayFromCollection(c As Collection, Optional LowerBound As Long = 1) As Variant
Dim a As Variant, val As Variant, i As Long
ReDim a(LowerBound To c.Count - 1 + LowerBound)
i = LowerBound
For Each val In c
If IsObject(val) Then
Set a(i) = val
Else
Let a(i) = val
End If
i = i + 1
Next val
ArrayFromCollection = a
End Function
[/pre]
Asa
 
Luke,


This works brilliantly. Thanks! One last question . . . I attached the above macro to a button. Is there a way to make the button invisible & inactive unless the worksheet is unlocked?


Other users access the workbook, and I don't want them accidentally bombarding my managers with email.


I thought something like the code below would do the trick:

[pre]
Code: 
Private Sub Worksheet_Activate()

If Sheet2.Protect = True Then
Button1_Click.Visible = False
Else Button1_Click.Visible = True
End If

End Sub
[/pre]
 
Tome,

If the sheet is protected, we won't be able to alter the status of anything on that sheet. However, you could simply add the If statement to beginning of your main macro, like:

[pre]
Code: 
Sub Mail_small_Text_Outlook()
If Sheet2.Protect = True Then Exit Sub
'Otherwise, carry on with regular code.
'etc
End Sub
[/pre]
 
Luke,


The code was working last week, but now I am getting the following error:


Run Time Error 1004: Unable to get the VLookup property of the WorksheetFunction class.


The code line that is highlighted in debugger is "MyEmail = . . . . " (Line 23)


I am using the unmodified script you posted last week.


your help would be greatly appreciated.
 
You must log in or register to reply here.
Back
Top