PDA

View Full Version : Private Sub Worksheet_Calculate() - Not running when workbook opens



mykal66
03-31-2015, 05:38 AM
Hi.

I've set up a simple spread sheet (just 6 columns) to automatically monitor when a reminder needs to be sent to a manager. I struggled with one issue yesterday which a member of the forum helped me with but I now have another issue I cant' figure out.

Column F works out how many days until a review is due automatically using the NOW() function which works fine. I wanted the macro to run automatically when the workbook was opened each day and if any of the values showed 14 send a basic email to advise a manager to book a review. This works perfectly if I manually change any of the values in column F to 14 but even if the value changes to 14 automatically when the workbook is opened it will not auto send the email.

I tried changing the macro to Worksheet Open() too but no joy. I have also tried attaching the macro to a command button to manually trigger it after the workbook is open but his then just finds issues elsewhere in the code.

Is there something I am doing wrong or is it not possible to trigger the macro on open to check if any of the values are 14 and send emails?

The workbook is attached and if you enter 14 into column F you can get the jist of what I was hoping would be automatic when the book was opened each day - I am happy to attach the macro to a button too if need be.

Always appreciate the help you guys give

Thanks

jonh
04-01-2015, 02:15 AM
Well I don't know about Mail_with_outlook2 but Worksheet_Calculate seems to work here.

Type stop at the begining of the procedures.


Private Sub Worksheet_Calculate()
stop
...


Sub Mail_with_outlook2()
stop
...

Save. Close. Reopen.

If the code stops at the first Stop it is running. Press f5.
If the code stops at the second Stop it's doing the email thing. Press f8 until you find the error.

Bob Phillips
04-01-2015, 02:25 AM
The essence of your problem is your formula, because you use NOW() you get the time deducted as well, so it will never be 14.

In addition, testing for E4>(1/1/1999) is not testing for greater than 1st Jan 1999, it is testing for greater than 1 divided by 1 divided by 1999, a very small number.

Your formula would better read as

=IFERROR(IF(E6>--"1999-01-01",E6-TODAY(),0),0)

and your workbook open procedure is shown below.

But I still think you have a problem. Say the Contract end date is 18/04/2015 a Saturday. That formula will only show 14 on Sat 4th April, and as I assume you won't be in on a Saturday, you won't open the workbook, the macro won't run when it's foirmula returns 1q4, and on the following Monday it will show 12. So it will be skipped.


Private Sub Workbook_Open()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimit As Double

NotSentMsg = ""
SentMsg = "Mail Sent"
MyLimit = 14
Set FormulaRange = Worksheets("Broker Agreements").UsedRange.Columns("F")

On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells

With FormulaCell

If Not IsNumeric(.Value) Then

MyMsg = "Not numeric"
Else

If .Value = MyLimit Then

MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then

Call Mail_with_outlook2
End If
Else

MyMsg = NotSentMsg
End If
End If

Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell

ExitMacro:
Application.EnableEvents = True
Exit Sub

EndMacro:
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
Resume ExitMacro
End Sub

mykal66
04-07-2015, 07:08 AM
Hi guys - sorry it's taken a few days to come back to you, first day back after hols. Thank you for your help, I will have a play with the code you have given me and see how it goes

Mykal

mperrah
04-07-2015, 10:08 AM
I had a project that was date specific needing emails sent.

I used this code in the sheet to display the items age in stock
cell D2 is the received date, the check on A2 limits empty row errors by not running script if that rows is empty.
the code is at the end of the row copied down.

=IF($A2="","",IF(30-(TODAY()-$D2)<=15,30-(TODAY()-$D2),""))

I used this to send and email when my inventory was 15 days old.
we had to pay on 30 days, so at 15 I sent an email of the status.
I added a command button on the sheet and assigned this macro to it.


Sub Mail_RcvrSheet()
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Set Sourcewb = ActiveWorkbook

'Copy the sheet to a new workbook
Worksheets("Receivers").Copy

Set Destwb = ActiveWorkbook

'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
'We exit the sub when your answer is NO in the security dialog that you only
'see when you copy a sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

'Change all cells in the worksheet to values if you want
With Destwb.Sheets(1).UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False

'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail "youremail@email.com", _
"Review Needed Soon!"
On Error GoTo 0
.Close SaveChanges:=False
End With

'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr

With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub

hope this helps,

-mark