Command button to send/display email to corresponding email address if condition is met

[rimilam]

Hello VBA experts,

I have a spreadsheet that I would like to add a command button to that would populate an email to the corresponding email address, but only if a condition is met (an upcoming due date). I have tried several versions of code, but none have worked so far and I'm also a beginner VBA user so I haven't been able to try anything too complicated.

Here is how my spreadsheet is set up: I have a due date in Column G and a drop down list of names in Column I, which populates the email address for that person into Column L. What I want to do is add a command button which, when clicked, will display an email to the person's email address in Column L, but only if the due date in Column G is coming up within the week, or is past due. I need the macro to check each row for the due date and email address, then move on to the next row. I did try creating a "helper" Column J that says "email" if the due date is <=TODAY() +7, but it's just not working. I don't know if it's worth noting, but there are three worksheets in my workbook, but this button and macro only needs to apply to one.

I tried using the follow code which I found on Ron de Bruin's excel automation site, but it isn't working, or giving me any errors, so I'm not sure where the problem is. Any help would be greatly appreciated. I hope that all makes sense.

Sub DisplayEmail()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")

On Error GoTo cleanup
For Each cell In Columns("L").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "J").Value) = "email" Then

Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Action Item Due"
.Body = "Hi there, " & vbNewLine & vbNewLine & _
"You have an action item with an upcoming due date."
'You can add files also like this
'.Attachments.Add ("C:\test.txt")
.Display 'Or use Display
End With
On Error GoTo 0
Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True
End Sub

 

[DanteAmor]

Hi and welcome to MrExcel.

Put here a sample of your data, change confidential information for generic data.
Use the XL2BB tool to put a range of cells here (see my signature).
In the rows of your data range indicate which, based on your condition, are the records that should be sent by mail.

 

[rimilam]

Here is my spreadsheet. I created columns J-M to work as "helper" columns which will be hidden once I get the macro working. The individuals listed in Column I should get an email to address in Column M if the text in Column K =email. Those individuals have a due date that is upcoming or past due, as indicated by the red highlighted cells. I want all emails to display upon clicking on a command button.

Copy of Long Screw Meeting Tracker.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1					Project:									REVISION BOX
2					Long Screws									6/17/2020
3														1
4					PREPARED BY: Quinten	Phone: Insert Phone
5		Issue / Item (What)
6		Task	Subtask	Description:	Recommended Actions	Open Date	Promise /Revised Date	Actual Completion Date	Champion					Comments
7		Marketing/Sales
8					Surgical Technique Release		26-Jun-20		Justin	email	email	justin.hyer@osteocentric.com	justin.hyer@osteocentric.com
9
10
11		Manufacturing
12		6		Parts through final inspection
13			1		#110040 2.5mm Drill bit, PO 626	3-Jun-20	14-Aug-20		Robin	email	email	robin.wheelwright@osteocentric.com	robin.wheelwright@osteocentric.com	5-13, Inspection, AO Flat defect, Andy, to speak with Eric to give approval on instruments with cosmetic defect 5-20, Eric approved, but need to work with supplier on improving, create an NCMR. 6-3, Update from Lydia on timeline, FAI being re-done, to inspect for Cal Lines. 6-10, In MRB,Choose to Scrap? Confirm with Andy. Amy to contact Eva-Lution on drill production, Q to look into off-the shelf parts. TR-NCMR-064-20 6-17, Working with PI, updating prints on both sides for release, Waiting on Validation Lab Report. 6-23, Rev C Scraped, Waiting for Rev D parts to arrive
14			12		Fastener Sleeve (110701) -Re-order new tolerance option	17-Jun-20	2-Oct-20		Justin			justin.hyer@osteocentric.com	justin.hyer@osteocentric.com	6-17, None on order, get with Rosa. 6-24, Managing inventory?? Todd, Deepa, Amy, Linda to discuss at MRB today.
15							9-Aug-20		Thomas	email	email	thomas.perry@osteocentric.com	thomas.perry@osteocentric.com
Open issues

Cell Formulas
Range	Formula
J1:J15	J1	=IF(G1="","",IF(G1<=(TODAY()+7),"email",""))
K1:K15,M1:M15	K1	=J1
L1:L15	L1	=IF(I1="Robin","robin.wheelwright@osteocentric.com",IF(I1="Justin","justin.hyer@osteocentric.com",IF(I1="Thomas","thomas.perry@osteocentric.com","")))

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
G1:G43	Expression	=$K1="email"	text	NO

Cells with Data Validation
Cell	Allow	Criteria
I8:I10	List	Robin,Justin,Thomas
I12:I15	List	Robin,Justin,Thomas

 

[DanteAmor]

Try this. I considered column J to go through the cells since it is where the criteria will be checked.

Sub DisplayEmail()
  Dim OutMail As Object
  Dim cell As Range
  
  Application.ScreenUpdating = False
  
  For Each cell In Range("J7", Range("J" & Rows.Count).End(3))
    If cell.Value = "email" And Cells(cell.Row, "L") Like "?*@?*.?*" Then
    
      On Error Resume Next
        Set OutMail = CreateObject("Outlook.Application").CreateItem(0)
        With OutMail
          .To = Cells(cell.Row, "L").Value
          .Subject = "Action Item Due"
          .Body = "Hi there, " & vbNewLine & vbNewLine & _
              "You have an action item with an upcoming due date."
          .Display 'Or use .Send to send
        End With
      On Error GoTo 0
    
    End If
  Next cell
  
  Set OutMail = Nothing
  Application.ScreenUpdating = True
End Sub

 

[rimilam]

This works beautifully!! Thank you so much!!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.