E-mail VBA based on specific cell value

[stumcvic]

Hi all,

I have a multisheet workbook that is used as timesheets (with each sheet being a different employee). What I would like is for whenever an employee has not completed their time sheet from the day previously, an email reminder to be sent to them. Now, I am a novice when it comes to this stuff, however I have got the code to this stage and linked it to a button:

Sub Test1()


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("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "send" _
And LCase(Cells(cell.Row, "D").Value) <> "Sent" Then


Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Time Sheet"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Please update your timesheet"



.send
End With
On Error GoTo 0
Cells(cell.Row, "D").Value = "Sent"
Set OutMail = Nothing
End If
Next cell


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

The issue I have is that it only searches that one worksheet, where ideally I would like the one button to run a loop on all of the worksheets (except the first, ideally will be where the button is placed). All of the fields are the same in each worksheet. Column A is the employees name, column B is the email address, column C is an IF function that checks whether the email should be sent, and column D is the field that will state SENT after the email has been sent to repeat repetitive emails being distributed unnecessarily.

Any help would be greatly appreciated, especially if you could give me some sort of an explanation of what you have done.

Cheers.

 

[stumcvic]

This is awkward.

Have I asked a simple/stupid question here? I'm looking through online as best I can, however I'm struggling to work out where I should be changing the code in order to search all the worksheets.

 

[Perpa]

stumcvic,

Welcome to the Forum!
The macro below will step through each worksheet and run Test1 for each worksheet.
You did not specify the type of 'button' used, whether an ActiveX Command Control Button, or a Form Control button.
But the way you posted 'Test1' I assume you used the Form Control button.
So make the name change shown below to enter the name of your master sheet, the one with the button.
Then put this new code in a standard module as you did with the original code.
Then change the macro assigned to the button from 'Test1' to 'All_Sheets'. You do that by right clicking on the button,
then select 'Assign a Macro', then select 'All_Sheets'. Then save the worksheet. That's it you are ready to give it a test run.
Good luck!
Perpa

Sub All_Sheets()
    Dim lr As Long
    Dim ws As Worksheet
    Dim wsDest As Worksheet
    
    Set wsDest = Sheets("MasterSheet")     'Change to your master sheet name with the button
    
    For Each ws In ActiveWorkbook.Worksheets
    '  The following line tells VBA not to do anything with the MasterSheet
        If ws.Name <> wsDest.Name Then
  call Test1     'This calls your macro
        End If
    Next ws
    Msgbox "Reminders Sent"
End Sub

 

[stumcvic]

Hi,

Thanks Perpa. You were correct I am just using a form control button. I actually found a solution myself (although no doubt very messy and crude) by tweaking my code slightly to say:

Sub Test1()


Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range


Application.ScreenUpdating = False
For Each sh In Worksheets
sh.Activate
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(Cells(cell.Row, "C").Value) = "send" _
And LCase(Cells(cell.Row, "D").Value) <> "Sent" Then


Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Time Sheet"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Our file suggests that you haven't completed your timesheet for yesterday. Please rectify this." & Chr(13) & Chr(13) & "Kind Regards"



.display
End With
On Error GoTo 0
Cells(cell.Row, "D").Value = "Sent"
Set OutMail = Nothing
End If
Next cell


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

This is now looping through the entire workbook. One issue I am having however (which I am hoping someone may be able to help me with) is that my intention for having "Sent" appear in column D when the email has been sent is that if someone presses the button again, the system will recognise that the email has already been sent that day and therefore not repeat the action. At the minute however it is still sending even if Column D is filled in. Are you able to explain what I need to change in the code to pick up on this column?

Cheers.

 

[Perpa]

Hi,

Thanks Perpa....
One issue I am having however (which I am hoping someone may be able to help me with) is that my intention for having "Sent" appear in column D when the email has been sent is that if someone presses the button again, the system will recognise that the email has already been sent that day and therefore not repeat the action. At the minute however it is still sending even if Column D is filled in. Are you able to explain what I need to change in the code to pick up on this column?

Cheers.

Stumcvic,
Glad you got it figured out. As to your last request...

Replace this bit of code:

 On Error GoTo cleanup
 For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
 If cell.Value Like "?*@?*.?*" And _
 LCase(Cells(cell.Row, "C").Value) = "send" _
 And LCase(Cells(cell.Row, "D").Value) <> "Sent" Then

With this:

 On Error GoTo cleanup
 For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
 If LCase(Cells(cell.Row, "D").Value) = "Sent" Then goto cleanup
 If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "C").Value) = "send" Then

That should do it.
Perpa

 

[stumcvic]

Hi thanks for the help!

Weirdly it is still creating the emails even with the field filled in (I also understand what you have done here which is quite an accomplishment for me!). I don't really understand why, I'm 99% sure I have changed the correct code in the correct places, however I will paste it below just in case:

Sub Test1()


Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range


Application.ScreenUpdating = False
For Each sh In Worksheets
sh.Activate
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If LCase(Cells(cell.Row, "D").Value) = "Sent" Then GoTo cleanup
If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "C").Value) = "send" Then


Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Time Sheet"
.Body = "Dear " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Our file suggests that you haven't completed your timesheet for yesterday. Please rectify this." & Chr(13) & Chr(13) & "Kind Regards"



.display
End With
On Error GoTo 0
Cells(cell.Row, "D").Value = "Sent"
Set OutMail = Nothing
End If
Next cell


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

Realistically it isn't the end of the world if I can't sort this bit out, it would just be nice to have it a little neater.

Cheers.

 

[Perpa]

Hi thanks for the help!

Weirdly it is still creating the emails even with the field filled in ...QUOTE]


stumcvic,
If the cell where 'Sent' will be placed on each sheet is the same, say it is D2, then the following changes in red should work:
Perpa

Sub Test1()
 Dim OutApp As Object
 Dim OutMail As Object
 Dim cell As Range
 Application.ScreenUpdating = False
 For Each sh In Worksheets
 sh.Activate
 Set OutApp = CreateObject("Outlook.Application")

[COLOR=#ff0000]If Cells(2,"D").Value = "Sent" Then goto cleanup   'Change to your cell in column D[/COLOR]
[COLOR=#ff0000] On Error GoTo cleanup
 For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)[/COLOR]
 [COLOR=#ff0000]If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "C").Value) = "send" Then
[/COLOR]
 Set OutMail = OutApp.CreateItem(0)
 On Error Resume Next
 With OutMail
 .To = cell.Value
 .Subject = "Time Sheet"
 .Body = "Dear " & Cells(cell.Row, "A").Value _
 & vbNewLine & vbNewLine & _
 "Our file suggests that you haven't completed your timesheet for yesterday. Please rectify this." & Chr(13) & Chr(13) & "Kind Regards"
 .display
 End With
 On Error GoTo 0
 Cells(cell.Row, "D").Value = "Sent"
 Set OutMail = Nothing
 End If
 Next cell
 cleanup:
 Set OutApp = Nothing
 Next sh
 Application.ScreenUpdating = True
 End Sub

 

[stumcvic]

Hi Perpa,

The issue with that is that each day is a different row, and so the value will be on the next row each time. I worked out what I was missing though, and it was simple and frustrating. On the line:

If LCase(Cells(cell.Row, "D").Value) = "Sent" Then GoTo cleanup


I needed to have Sent with a lower case S. That was it. Thank you so much for your help, I believe I've got everything I need.

Cheers.

 

[stumcvic]

Sorry. I spoke too soon! This is working as it is, however I now have an issue that if I have sent one email, at any time in the month then the code will no longer let me send another one, even on a separate day. The code is currently:

Sub Test1()


Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range


Application.ScreenUpdating = False
For Each sh In Worksheets
sh.Activate
Set OutApp = CreateObject("Outlook.Application")


On Error GoTo cleanup
For Each cell In Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If LCase(Cells(cell.Row, "D").Value) = "1" Then GoTo cleanup
If cell.Value Like "?*@?*.?*" And LCase(Cells(cell.Row, "C").Value) = "send" Then


Set OutMail = OutApp.CreateItem(0)


On Error Resume Next
With OutMail
.To = cell.Value
.Subject = "Time Sheet"
.Body = "To " & Cells(cell.Row, "A").Value _
& vbNewLine & vbNewLine & _
"Our file suggests that you haven't completed your timesheet for yesterday. Please rectify this." & Chr(13) & Chr(13) & "Kind Regards"



.display


End With
On Error GoTo 0
Cells(cell.Row, "D").Value = "1"
Set OutMail = Nothing
End If
Next cell


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

I believe it is the part that I have highlighted that I need to edit. Obviously if somebody forgets to fill in the chart 3 times in a month I would like to send an email each time, however as soon as the first email goes out and a 1 (i changed this from sent) is in that cell in column D, it stops any other emails being released.

Again any insight would be appreciated.

Cheers.

 

[Perpa]

Sorry. I spoke too soon! This is working as it is, however I now have an issue that if I have sent one email, at any time in the month then the code will no longer let me send another one, even on a separate day....

Again any insight would be appreciated.

stumcvic,
What if you place the Date when you send the 1st reminder in the cell below...something like...

Cells(cell.Row, "D").value = "1" 
Cells(cell.Row, "D").Offset(1,0) = Date

Then check that cell each time to see if it is time to send a reminder again... Change the line you had in BOLD ...
One way would be to send a reminder when the Date changes...

If LCase(Cells(cell.Row, "D").Value) = "1"  and cells(cell.row,"D").Offset(1,0) = Date Then GoTo cleanup

Another way would make it a week later:

If LCase(Cells(cell.Row, "D").Value) = "1"  and cells(cell.row,"D").Offset(1,0)+7 < Date Then GoTo cleanup

Glad you have it working now. You are welcome.
Perpa