Option Explicit
Sub Test__Check_Date()
Call Check_Date("N", "O", "A", "T1", 5, 10, "Received date OVERDUE list for today [Microsoft Excel]")
End Sub
Sub Check_Date( _
requestedDate_ColumnLetter As String, _
toCheckIfEmpty_ColumnLetter As String, _
tagID_ColumnLetter As String, _
lastDateCheckedCellAddress As String, _
startRow As Long, _
numberOfDays As Integer, _
emailSubjectLine As String _
)
Dim todaysDate As Date
todaysDate = Date
'First check if emails were already sent today.
Dim dateLastChecked As String
Dim cellWithDateLastChecked As Range
Set cellWithDateLastChecked = Range(lastDateCheckedCellAddress)
cellWithDateLastChecked.Offset(0, -1).Value = "Last Chkd:"
With cellWithDateLastChecked
.Value = Trim(Remove_All_Non_Printing_Characters_Except_For_White_Spaces(.Value))
If IsDate(.Value) = True Then
.NumberFormat = "@"
.Value = Day(.Value) & "-" & Month_Abbreviation(Month(.Value))
dateLastChecked = .Value & " " & Year(Date)
'We already sent the email for today. Exit
If CDate(dateLastChecked) >= todaysDate Then Exit Sub
End If
End With
'Now check the column for Tag No. IDs to send emails for if received date is OVERDUE.
Dim lastRowWithData_In_RequestedDate_Column As Long
lastRowWithData_In_RequestedDate_Column = Cells(Rows.Count, requestedDate_ColumnLetter).End(xlUp).Row
Dim requestedDateColumn As Range
Set requestedDateColumn = Range(requestedDate_ColumnLetter & startRow & ":" & requestedDate_ColumnLetter & lastRowWithData_In_RequestedDate_Column)
Dim emailBody As String
emailBody = "Recieved date OVERDUE for the following Tag No. IDs:" & "<br>"
Dim requestedDate_In_CurrentRow As String
Dim cell As Range
For Each cell In requestedDateColumn
With cell
.Value = Trim(Remove_All_Non_Printing_Characters_Except_For_White_Spaces(.Value))
If IsNumeric(.Value) = True Then
.NumberFormat = "@"
.Value = CDate(.Value)
End If
If IsDate(.Value) = True Then
.NumberFormat = "@"
.Value = Day(.Value) & "-" & Month_Abbreviation(Month(.Value))
requestedDate_In_CurrentRow = .Value & " " & Year(Date)
If (CDate(requestedDate_In_CurrentRow) + numberOfDays <= todaysDate) _
And _
Trim(Remove_All_Non_Printing_Characters_Except_For_White_Spaces(Range(toCheckIfEmpty_ColumnLetter & .Row).Value)) = "" _
Then
emailBody = emailBody & "<br>" & "• " & Range(tagID_ColumnLetter & .Row).Value & " (Row " & .Row & ")"
End If
End If
End With
Next cell
'If indeed we have to send an email (there is AT LEAST one Tag No. ID OVERDUE), Then send the email.
If emailBody <> "Recieved date OVERDUE for the following Tag No. IDs:" & "<br>" Then Call Send_Mail_From_Excel2(emailSubjectLine, emailBody)
'And mark it that we sent the email for today so the email doesn't get sent more than once per day!
Range(lastDateCheckedCellAddress).Value = Day(todaysDate) & "-" & Month_Abbreviation(Month(todaysDate))
End Sub
Sub Test__Remove_All_Non_Printing_Characters_Except_For_White_Spaces()
Debug.Print Remove_All_Non_Printing_Characters_Except_For_White_Spaces(Chr(8) & " " & Chr(10) & "AA" & Chr(10) & "BE" & " ")
End Sub
Function Remove_All_Non_Printing_Characters_Except_For_White_Spaces(str As String)
'Important note from: https://docs.microsoft.com/en-us/office/vba/api/excel.worksheetfunction.clean
'The Clean function was designed to remove the first 32 nonprinting characters
'in the 7-bit ASCII code (values 0 through 31) from text. In the Unicode character set,
'there are additional nonprinting characters (values 127, 129, 141, 143, 144, and 157).
'By itself, the Clean function does not remove these additional nonprinting characters.
Remove_All_Non_Printing_Characters_Except_For_White_Spaces = Application.WorksheetFunction.Clean(str)
End Function
Sub Test__Month_Abbreviation()
MsgBox Month_Abbreviation(1)
End Sub
Function Month_Abbreviation(monthNumber As Integer)
Select Case monthNumber
Case 1
Month_Abbreviation = "Jan"
Case 2
Month_Abbreviation = "Feb"
Case 3
Month_Abbreviation = "Mar"
Case 4
Month_Abbreviation = "Apr"
Case 5
Month_Abbreviation = "May"
Case 6
Month_Abbreviation = "Jun"
Case 7
Month_Abbreviation = "Jul"
Case 8
Month_Abbreviation = "Aug"
Case 9
Month_Abbreviation = "Sep"
Case 10
Month_Abbreviation = "Oct"
Case 11
Month_Abbreviation = "Nov"
Case 12
Month_Abbreviation = "Dec"
End Select
End Function
Sub Send_Mail_From_Excel2(subjectLine As String, emailBody As String)
Dim OutlookApp As Object
Dim OutlookMail As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
'Send Mass Email Using Excel VBA Macro Code
With OutlookMail
.to = "youremail@some.com"
.CC = ""
.BCC = ""
.Subject = subjectLine
.HTMLBody = emailBody
'.Send ' or just put .Send to directly send the mail instead of display
.Display
End With
Set OutlookMail = Nothing
Set OutlookApp = Nothing
End Sub