Hi there i currently have below code whereby it will send email every time it meets target of 16, 64 and 125 however is it possible along with dates
for example only send email if value of 16 is within 3 months, 64 if it is within 6 month and 125 over one year period.
Private Sub Worksheet_Calculate()
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
On Error GoTo errHandler:
Sheet3.Unprotect Password:="1234"
NotSentMsg = "Not Sent"
SentMsg = "Sent"
With Me.Range("B6")
If Not IsNumeric(.Value) Then
MyMsg = "Not numeric"
Else
If .Value = 16 <= Now() - 90 Or .Value = 64 <= Now() - 190 Or .Value > 125 <= Now() - 365 Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_Outlook_With_Signature_Html_2
MsgBox "Email has been sent", vbInformation
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Application.EnableEvents = True
Sheet3.Protect Password:="1234"
On Error GoTo 0
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please Contact Admin"
End Sub
Hi Please see screenshot of yearly diary
enter image description here
Related
im currently having an error code 1004 with VBA for excel, I'm not too familiar with the program but I have been able to determine the issue with the code although i definitely do not know how to fix it.
TLDR on what the code is supposed to do;
once the form is filled copy relevant data to a separate workbook
send an email to the relevant party of new entry
save the entry as a PDF
reset the workbook with the ticket number + 1 to mark up
the issue lies within the last step, once the first PDF file was created the workbook will no longer save as the ticker is stuck on Ticket# 1
Application.ScreenUpdating = False
If Range("H3").Value = "" Then MsgBox "Please Enter Device Serial Number"
Range("H3").Select
If Range("H3").Value = "" Then Exit Sub
If Range("M3").Value = "" Then MsgBox "Please Enter Reference Standard ID"
Range("M3").Select
If Range("M3").Value = "" Then Exit Sub
If Range("K9").Value = "" Then MsgBox "Please Enter Atleast One Dimensional Check"
Range("K9").Select
If Range("K9").Value = "" Then Exit Sub
If Range("Q9").Value = "" Then MsgBox "Please Enter Visual Check for Damage"
Range("Q9").Select
If Range("Q9").Value = "" Then Exit Sub
If Range("U9").Value = "" Then MsgBox "Please Enter Inital for Damage Check"
Range("U9").Select
If Range("U9").Value = "" Then Exit Sub
If Range("Q10").Value = "" Then MsgBox "Please Enter Visual Check for Wear"
Range("Q10").Select
If Range("Q10").Value = "" Then Exit Sub
If Range("U10").Value = "" Then MsgBox "Please Enter Inital for Wear Check"
Range("U10").Select
If Range("U10").Value = "" Then Exit Sub
If Range("Q11").Value = "" Then MsgBox "Please Enter Visual Check for Travel"
Range("Q11").Select
If Range("Q11").Value = "" Then Exit Sub
If Range("U11").Value = "" Then MsgBox "Please Enter Inital for Travel Check"
Range("U11").Select
If Range("U11").Value = "" Then Exit Sub
If Range("Q12").Value = "" Then MsgBox "Please Enter Visual Check for Zero"
Range("Q12").Select
If Range("Q12").Value = "" Then Exit Sub
If Range("U12").Value = "" Then MsgBox "Please Enter Inital for Zero Check"
Range("U12").Select
If Range("U12").Value = "" Then Exit Sub
If Range("Q13").Value = "" Then MsgBox "Please Enter Visual Check for Repeatability"
Range("Q13").Select
If Range("Q13").Value = "" Then Exit Sub
If Range("U13").Value = "" Then MsgBox "Please Enter Inital for Repeatability Check 3x"
Range("U13").Select
If Range("U13").Value = "" Then Exit Sub
If Range("C23").Value = "True" Then MsgBox "Please Check Final Verification Pass or Fail"
If Range("C23").Value = "True" Then Exit Sub
Workbooks.Open "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\VerificationData(DONOTDELETE).xlsx"
Application.Run (["GetMax"])
Application.Run (["SavePrintEmail"])
Application.Run (["CopyClear"])
Application.ScreenUpdating = True
End Sub
Private Sub GetMax()
Dim WorkRange As Range
Dim MaxVal As Double
Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
Set WorkRange = ActiveWorkbook.Worksheets("Data").Range("AK:AK")
MaxVal = WorksheetFunction.Max(WorkRange)
Workbooks("PIV-001.xlsm").Activate
ActiveWorkbook.Worksheets("PIV-001").Unprotect ("Moldamatic")
ActiveWorkbook.Worksheets("PIV-001").Range("U21").Value = MaxVal + 1
End Sub
Private Sub SavePrintEmail()
ThisWorkbook.Save
If Len(Dir("\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date), vbDirectory)) = 0 Then
MkDir "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date)
End If
Sheets("PIV-001").Select
Sheets("PIV-001").ExportAsFixedFormat xlTypePDF, "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date) & "\" & Range("U21").Value & "-" & Year(Date), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.createitem(0)
On Error Resume Next
With OutMail
.To = "Spage#moldamatic.com"
.CC = ""
.BCC = ""
.Subject = "NEW INSTRUMENT VERFICATION (TICKET# " & Range("U21").Value & " INSTRUMENT ID# " & Range("H3").Value & " RESULT: " & Range("H22").Value & ")"
.HTMLBody = "An instrument has just been verfied, please see attached verification report. Verficiation results: " & Range("H22").Value & " "
.Attachments.Add "\\192.168.150.31\Quality Control\Calibration\Periodic Verification\" & Year(Date) & "\" & Range("U21").Value & "-" & Year(Date) & ".pdf"
.send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
ThisWorkbook.Save
End Sub
Private Sub CopyClear()
'Change path to database in line below
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "U21,C22,E22,H3,M3,B9,F9,I9,K9,B10,F10,I10,K10,B11,F11,I11,K11,B12,F12,I12,K12,B13,F13,I13,K13,Q9,U9,Q10,U10,Q11,U11,Q12,U12,Q13,U13,G17"
Set inputWks = ThisWorkbook.Worksheets("PIV-001")
Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
Set historyWks = ActiveWorkbook.Worksheets("Data")
With historyWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
End With
With historyWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "mm/dd/yyyy hh:mm:ss"
End With
.Cells(nextRow, "B").Value = Application.UserName
oCol = 3
For Each myCell In myRng.Cells
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
Workbooks("PIV-001.xlsm").Activate
Range("H3,M3,B9,F9,K9,B10,F10,K10,B11,F11,K11,B12,F12,K12,B13,F13,K13,Q9,U9,Q10,U10,Q11,U11,Q12,U12,Q13,U13,G17").Select
Selection.ClearContents
ActiveSheet.CheckBoxes.Value = False
Range("H3:L3").Select
ThisWorkbook.Worksheets("PIV-001").Protect ("Moldamatic")
Workbooks("PIV-001.xlsm").Save
Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
Workbooks("VerificationData(DONOTDELETE).xlsx").Save
Workbooks("VerificationData(DONOTDELETE).xlsx").Close
End Sub
the issue laid within the MaxVal string, changed the code to get rid of it
new code
Private Sub GetMax()
Dim WorkRange As Range
Workbooks("VerificationData(DONOTDELETE).xlsx").Activate
Set WorkRange = ActiveWorkbook.Worksheets("Data").Range("AK:AK")
Workbooks("PIV-001.xlsm").Activate
ActiveWorkbook.Worksheets("PIV-001").Unprotect ("Moldamatic")
ActiveWorkbook.Worksheets("PIV-001").Range("U21").Value =
Range("U21").Value + 1
End Sub
I have code in which if column I, it will look at that value and then send an email if it matches any of my limits. Then I have also included a refresh anytime I edit another column.
This code is in ThisWorkbook
Private Sub Workbook_Open()
Call Worksheet_Calculated
End Sub
This is my code in Sheet1 that will run the operation if anything in column G changes.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address Like "$F$*" Then
Call Worksheet_Calculated
End If
End Sub
This code is in a module. It checks to see if any value in column I is any of of the MyLimit Values, if it is, in column I, it will say sent or not sent. If sent, an email will be generated.
Option Explicit
Public Sub Worksheet_Calculated()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimita As Double
Dim MyLimitb As Double
Dim MyLimitc As Double
Dim MyLimitd As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimita = 100
MyLimitb = 50
MyLimitc = 10
MyLimitd = 1
'Set the range with Formulas that you want to check
'This is the column that shows how many days left
Set FormulaRange = Range("H5:H25")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = ""
ElseIf (.Value = MyLimita Or .Value = MyLimitb Or .Value = MyLimitc Or .Value = MyLimitd) Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook(FormulaCell)
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
The above code will call another module which will populate the email that I would like to send.
Option Explicit
Public FormulaCell As Range
Public Sub Mail_with_outlook(FormulaCell As Range)
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change the parenthesis for column that the email is in
strto = Cells(FormulaCell.Row, "K").Value
strcc = ""
strbcc = ""
strsub = "Payment Notification (PO --Enter PO # Here--)"
'Change the parenthesis for the Column that the POC is in
strbody = "Hi " & Cells(FormulaCell.Row, "J").Value & vbNewLine & vbNewLine & _
"This is a reminder to pay for a licensing/maintenance bill in: " & Cells(FormulaCell.Row, "H").Value & " days." & _
vbNewLine & vbNewLine & "Line 2" & _
vbNewLine & "Line 3" & _
vbNewLine & "Line 4" & _
vbNewLine & "Line 5" & _
vbNewLine & "Line 6"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
I want to continue running this code on start up and whenever column G is edited, but only in Sheet1.
I want when column I is negative to copy that entire row into sheet2.
In VBE, I have a spreadsheet where if the column 'I' reaches 'MyLimit_', then i will automatically get an email. I am trying to make this code run only when I change a certain column (G).
This code is for the sheet.
In column I, I am looking at the these values to see if they equal my limit. if they do, it will trigger and email being generated.
Option Explicit
Private Sub Worksheet_Calculate()
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim MyLimita As Double
Dim MyLimitb As Double
Dim MyLimitc As Double
Dim MyLimitd As Double
NotSentMsg = "Not Sent"
SentMsg = "Sent"
'Above the MyLimit value it will run the macro
MyLimita = 100
MyLimitb = 50
MyLimitc = 10
MyLimitd = 1
'Set the range with Formulas that you want to check
'This is the column that shows how many days left
Set FormulaRange = Me.Range("I5:I25")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If IsNumeric(.Value) = False Then
MyMsg = ""
ElseIf .Value = MyLimita Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
ElseIf .Value = MyLimitb Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
ElseIf .Value = MyLimitc Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
ElseIf .Value = MyLimitd Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_with_outlook
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
This code is what I put into the module. This is basically all the code I used to generate my email and then populate with the appropriate info.
Option Explicit
Public FormulaCell As Range
Sub Mail_with_outlook()
Dim OutApp As Object
Dim OutMail As Object
Dim strto As String, strcc As String, strbcc As String
Dim strsub As String, strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
'Change the parenthesis for column that the email is in
strto = Cells(FormulaCell.Row, "L").Value
strcc = ""
strbcc = ""
strsub = "Payment Notification (PO --Enter PO # Here--)"
'Change the parenthesis for the Column that the POC is in
strbody = "Hi " & Cells(FormulaCell.Row, "K").Value & vbNewLine & vbNewLine & _
"This is a reminder to pay for a licensing/maintenance bill in: " & Cells(FormulaCell.Row, "I").Value & " days." & _
vbNewLine & vbNewLine & "Line 2" & _
vbNewLine & "Line 3" & _
vbNewLine & "Line 4" & _
vbNewLine & "Line 5" & _
vbNewLine & "Line 6"
With OutMail
.To = strto
.CC = strcc
.BCC = strbcc
.Subject = strsub
.Body = strbody
'You can add a file to the mail like this
'.Attachments.Add ("C:\test.txt")
.Display ' or use .Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
You can run a code automatically when the workbook is opened by calling it from the Workbook_Open() procedure.
The Worksheet_Change(ByVal Target As Range) procedure fires every time there's a chance, and then you can use the Address property of Target to see if the change was within Column G.
In the ThisWorkbook module:
Private Sub Workbook_Open()
Call YourProcedureName
End Sub
In a Sheet module:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address Like "$G$*" Then
Call YourProcedureName
End If
End Sub
In a regular module:
Public Sub YourProcedureName()
'Your code here
End Sub
I am completely lost so any help will be greatly appreciated.
I am attempting to cancel 2 scheduled event that are triggered when the Workbook is opened, and repeated using the Application.Ontime method.
I know that to terminate the OnTime schedule loop, you must provide the exact time that it is scheduled to run and that having multiple Application.OnTime tasks requires multiple variables.
This is why I have set two Public variables (Header of the document below Options Explicit):
Dim dTime as Date
Dim dTime2 as Date
The scheduler use these Variables and everything works properly as the code runs every minute.
dTime's value is set inside the TaskTracker function to be:
dTime = Now() + TimeValue("00:01:00")
Application.OnTime dTime, "TaskTracker", , True
dTime2's value is set inside the Autoclear function to be:
dTime2 = Now() + TimeValue("00:01:00")
Application.OnTime dTime, "AutoClear", , True
Despite all this, I get a Method 'ONTIME' of Object'Application' error message when attempting to run the function at the end of the module:
Function AutoDeactivate()
Application.OnTime EarliestTime:=dTime, Procedure:="TaskTracker", _
Schedule:=False
Application.OnTime EarliestTime:=dTime2, Procedure:="AutoClear", _
Schedule:=False
End Function
This is where I absolutely do not get what is going wrong. Triggering the Debug brings me to the OnTime section of each procedure cancel attempt.
Below is the script that contains these elements. Hopefully this will give you guys some insight as to why these event can't be canceled.
Option Explicit
Dim dTime As Date
Dim dTime2 As Date
'------------------------------------------------------------
'This is what checks cells to define if an email notification has to be sent, and what the content of that email should be.
'------------------------------------------------------------
Function TaskTracker()
Dim FormulaCell As Range
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim SendTo As String
Dim CCTo As String
Dim BCCTo As String
Dim MyLimit As Double
Dim MyLimit2 As Double
dTime = Now() + TimeValue("00:01:00")
NotSentMsg = "Not Sent"
SentMsg = "Sent"
SendTo = ThisWorkbook.Worksheets("Tasks").Range("D2")
CCTo = ThisWorkbook.Worksheets("Tasks").Range("E2")
BCCTo = ThisWorkbook.Worksheets("Tasks").Range("F2")
MyLimit = Date
MyLimit2 = ((Round(Now * 1440, 0) - 30) / 1440)
Set FormulaRange = ThisWorkbook.Worksheets("Tasks").Range("F5:F35")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If DateValue(CDate(.Value)) = MyLimit Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
strTO = SendTo
strCC = CCTo
strBCC = BCCTo
strSub = "[Task Manager] Reminder that you need to: " & Cells(FormulaCell.Row, "B").Value
If Cells(FormulaCell.Row, "C").Value = "" Then
strBody = "Greetings, " & vbNewLine & vbNewLine & _
"Your task : " & Cells(FormulaCell.Row, "B").Value & " is nearing its Due Date: " & Cells(FormulaCell.Row, "F").Value & "." & vbNewLine & "A wise decision would be to complete this task before it expires!" & _
vbNewLine & vbNewLine & "Truly yours," & vbNewLine & "Task Manager"
Else
strBody = "Hello, " & vbNewLine & vbNewLine & _
"Your task : " & Cells(FormulaCell.Row, "B").Value & " with the mention: " & Cells(FormulaCell.Row, "C").Value & " is nearing its Due Date: " & Cells(FormulaCell.Row, "F").Value & "." & vbNewLine & "A wise decision would be to complete this task before it expires!" & _
vbNewLine & vbNewLine & "Truly yours," & vbNewLine & "Task Manager"
End If
If sendMail(strTO, strSub, strBody, strCC) = True Then MyMsg = SentMsg
End If
Else
MyMsg = NotSentMsg
End If
If .Value = MyLimit2 Then
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
ExitMacro:
Exit Function
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
Application.OnTime dTime, "TaskTracker", , True
End Function
'------------------------------------------------------------
'This is the function that clears the rows of Completed Tasks
'------------------------------------------------------------
Function AutoClear()
Dim i As Integer
dTime2 = Now() + TimeValue("00:01:00")
With Tasks
For i = 5 To 35
If .Cells(i, 4).Value Like "Done" And .Cells(i, 5).Value = "1" Then
.Cells(i, 1).ClearContents
.Cells(i, 2).ClearContents
.Cells(i, 3).ClearContents
.Cells(i, 5).ClearContents
.Cells(i, 6).ClearContents
.Cells(i, 4).Value = "Pending"
.Cells(i, 7).Value = "Not Sent"
End If
Next i
End With
Tasks.AutoFilter.ApplyFilter
Application.OnTime dTime2, "AutoClear", , True
End Function
'------------------------------------------------------------
'ThisWorkbook calls this to deactivate the Application.OnTime. This "should" prevent the Excel process from reoppening the worksheets.
'------------------------------------------------------------
Function AutoDeactivate()
On Error Resume Next
Application.OnTime EarliestTime:=dTime, Procedure:="TaskTracker", _
Schedule:=False
Application.OnTime EarliestTime:=dTime2, Procedure:="AutoClear", _
Schedule:=False
End Function
It looks like it was a setup mistake!
Option Explicit
Dim dTime As Date
Dim dTime2 As Date
Application.OnTime dTime, "TaskTracker", , True
Application.OnTime dTime2, "AutoClear", , True
With the AutoDeactivation function called when the workbook closes does work as intended!
Function AutoDeactivate()
On Error Resume Next
Application.OnTime EarliestTime:=dTime, Procedure:="TaskTracker", _
Schedule:=False
Application.OnTime EarliestTime:=dTime2, Procedure:="AutoClear", _
Schedule:=False
End Function
Workbook_BeforeClose:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call AutoDeactivate
End Sub
What was happening is pretty idiotic. I had an issue with canceling the event at Work, so I took the Excel Sheet home and coded the fix found above. Yet, it still didn't work. Not because there was a mistake in it, but because I didn't have Outlook at home! :P
Not having the Outlook application prevented the event from being rescheduled after running once (resulting in an auto-dismissed ActiveX error message).
So as soon as I took this script back to work (where Outlook is installed) and everything worked properly :)
Marking this as resolved by myself haha.
I have something that notify me an hour before it happens. For that, I use the NOW function in VBA as I need it to check for the Date as well.
The problem is the script runs every 20 seconds so I can't have it consider seconds for the NOW function.
Is there a way to remove those? To have only like (DAY,MONTH,YEAR,HOUR,MINUTE)?
Something along those lines:
MyLimit = NOW(DAY,MONTH,YEAR,HOUR,MINUTE)
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If .Value = MyLimit Then
Call Notify
Here is the script in which I attempt to detect the date and time.
Option Explicit
Public Function AutoRun()
Application.OnTime Now + TimeValue("00:00:20"), "TaskTracker2"
End Function
Public Sub TaskTracker2()
Dim FormulaCell As Range
Dim FormulaRange As Range
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
Dim SendTo As String
Dim CCTo As String
Dim BCCTo As String
Dim MyLimit As Date
NotSentMsg = "Not Sent"
SentMsg = "Sent"
SendTo = Range("D2")
CCTo = Range("E2")
BCCTo = Range("F2")
MyLimit = Format((Now), "DD/MM/YYYY HH:MM")
Set FormulaRange = Range("E5:E35")
On Error GoTo EndMacro:
For Each FormulaCell In FormulaRange.Cells
With FormulaCell
If .Value = MyLimit Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
strTO = SendTo
strCC = CCTo
strBCC = BCCTo
strSub = "[Task Manager] Reminder that you need to: " & Cells(FormulaCell.Row, "A").Value
strBody = "Hello Sir, " & vbNewLine & vbNewLine & _
"This email is to notify that you that your task : " & Cells(FormulaCell.Row, "A").Value & " with the following note: " & Cells(FormulaCell.Row, "B").Value & " is nearing its Due Date." & vbNewLine & "It would be wise to complete this task before it expires!" & _
vbNewLine & vbNewLine & "Truly yours," & vbNewLine & "Task Manager"
If sendMail(strTO, strSub, strBody, strCC) = True Then MyMsg = SentMsg
End If
Else
MyMsg = NotSentMsg
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Next FormulaCell
AutoRun
ExitMacro:
Exit Sub
EndMacro:
Application.EnableEvents = True
MsgBox "Some Error occurred." _
& vbLf & Err.Number _
& vbLf & Err.Description
End Sub
To strip the seconds off Now, you can use some maths or to-and-from text conversion.
CDate(format(Now, "dd-mmm-yyyy hh:mm"))
'... or,
CLng(Now * 1440)/1440
Both of those return a true, numerical datetime value with the seconds stripped off. They do not average the seconds to the nearest minute; simply remove them.
You could just round MyLimit to the nearest minute:
MyLimit = Round(Now * 1440, 0) / 1440
Consider, when comparing it to the contents of a cell, that you might need to use a <= or >= comparison to avoid problems if the time changes at the "wrong" time for an equality to hold true.
Another method would be this:
MyLimit = now-second(now)/60/60/24
second(now) returns the seconds, and the /60/60/24 converts it to days, which every date and time is stored in. Use this or Jeeped's answer, any one of these should work.
Edit:
To avoid the tiny but existing possibility of error, use this:
MyLimit = now
MyLimit =MyLimit -second(MyLimit)/60/60/24
Try limit = Format((Now), "DD/MM/YYYY HH:MM")
Use the Date function instead of the NOW function
https://msdn.microsoft.com/en-us/library/aa227520(v=VS.60).aspx
UPDATE
I usually just go with the function =TIME(HOUR(NOW()),MINUTE(NOW()),0)
Alternative approach per VBA Office 2010 and later:
Dim DateWithoutSeconds : DateWithoutSeconds = DateAdd("s",-Second(Now),Now)
Notice that the minus (-) removes the seconds.
More info at https://msdn.microsoft.com/en-us/library/office/gg251759.aspx