excel to send email when all dates in column are due

[hsolanki]

Hi I have an staff training record whereby in column F-Z starting from row 9 with the expiry date and in column A9 onward all the staff name and type of training in columns F9-Z9.

i want macro to send email with the all the Due date in each column to One send email with the name, due date and types of training are due for the column F, for example. and so on for different column to different people.

i would really appreciate if someone could help me with the above query.

btw Happy New Year 2021 to all.

 

[hsolanki]

Good Morning all and Happy New Year.

can anyone help me with my above qurey? Thank you in advance

 

[Logit]

The following will check dates in Col C. If the date listed is older than TODAYs date, an email will be created listing ALL expired dates and the corresponding name in Col B.

Option Explicit

Sub AutoFilter_Date_Examples()
Application.ScreenUpdating = False
    With Sheet1.Range("C:C")
        
      'Before Date
      .AutoFilter Field:=1, Criteria1:="<" & Date - 1
    
    End With
    Send_newemail
End Sub

Sub Send_newemail()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim Rng As Range


    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    'First highlight selection to send in output
        
    Set Rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set Rng = Range("B:C").SpecialCells(xlCellTypeVisible)
  
    On Error GoTo 0

    If Rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    
      
    With OutMail
        .To = Range("F2").Value
        .CC = ""
        .Subject = "Updated List"
        .HTMLBody = "Hi," & vbNewLine & vbNewLine & "This is the list of names whose dates have passed." & RangetoHTML(Rng)
        .display
        '.Send
   End With
   Sheet1.ShowAllData
   Set OutMail = Nothing
   Set OutApp = Nothing
    Application.ScreenUpdating = True
End Sub

Function RangetoHTML(Rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    'Copy the range and create a new workbook to past the data in
    Rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Headers in B3:C3 .... Names & Expiration Dates begin in B4 & C4. The code can be amended to correspond to your project needs.



*********************************************************

The following checks Col C if posted date is 7 days from current date. If so, an email is sent to the corresponding email advising the employee listed
of pending action.

Option Explicit

Sub emailall()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp, OutMail

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

Sheets("Sheet1").Select
lRow = Cells(Rows.Count, 2).End(xlUp).Row

For i = 2 To lRow
  If Cells(i, 3).Value = Date Then
     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

        toList = Cells(i, 2)    'gets the recipient from col B
        CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
        eSubject = "You are scheduled for an audit on " & Cells(i, 3) & " at " & Cells(i, 4) & " " & Cells(i, 6)
        eBody = "Greetings : " & vbCrLf & vbCrLf & "Scheduled audit is upcoming on the date indicated above."
        
        On Error Resume Next
        With OutMail
        .To = toList
        .CC = CCList
        .BCC = ""
        .Subject = eSubject
        .Body = eBody & .EntireRow(i, 1)
        '.bodyformat = 1
        .Display   ' ********* Creates draft emails. Comment this out when you are ready
        '.Send     '********** UN-comment this when you  are ready to go live
        End With
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 Cells(i, 12) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i
Set OutApp = Nothing
ActiveWorkbook.Save

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
Sheets("Sheet1").Range("A1").Select
End Sub

Sub emailall2()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList, CCList As String
Dim eSubject As String
Dim eBody As String
Dim OutApp, OutMail


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


Sheets("Sheet1").Select
lRow = Cells(Rows.Count, 2).End(xlUp).Row

Set OutApp = CreateObject("Outlook.Application")

For i = 2 To lRow
  If Cells(i, 3).Value = Date + 7 Then
     Set OutMail = OutApp.CreateItem(0)


        toList = Cells(i, 2)    'gets the recipient from col B
        CCList = Cells(i, 8) & ", " & Cells(i, 9) & ", " & Cells(i, 10)
        eSubject = "You are scheduled for an audit on " & Cells(i, 3) & " at " & Cells(i, 4) & " " & Cells(i, 6)
        eBody = "Greetings : " & vbCrLf & vbCrLf & "Scheduled audit is upcoming on the date indicated above."
        
        On Error Resume Next
        With OutMail
        .To = toList
        .CC = CCList
        .BCC = ""
        .Subject = eSubject
        .Body = eBody
        '.bodyformat = 1
        .Display   ' ********* Creates draft emails. Comment this out when you are ready
        '.Send     '********** UN-comment this when you  are ready to go live
        End With
 
    On Error GoTo 0
    Set OutMail = Nothing
 Cells(i, 12) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i

Set OutApp = Nothing

ActiveWorkbook.Save


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
Sheets("Sheet1").Range("A1").Select
End Sub

Site	Email	Date	Tiime	Address	Time Zone	Area	Area Manager	Region Manager	Director	Subject	Email Sent Verification
5	Site5@email.com	1/11/2021	12:00 pm	123 Happy St	CST	100	areamanager1@email.com	regionm1@email.com	director1@email.com	Leave
10	Site10@email.com	5/24/2018	6:00 am	12 Lonely Ave	EST	100	areamanager2@email.com	regionm2@email.com	director2@email.com	This
12	Site12@email.com	8/4/2017	6:00 m	3 Snippy Dr	CST	100	areamanager3@email.com	regionm1@email.com	director1@email.com	Column
15	Site15@email.com	4/26/2020	12:00 pm	4 Old Farm	EST	200	areamanager4@email.com	regionm1@email.com	director1@email.com	Blank
18	Site18@email.com	8/1/2017	6:00 am	5 Nowhere St	CST	200	areamanager5@email.com	regionm2@email.com	director2@email.com

 

[hsolanki]

Hi Logic Thank you so much for your time and the code you have done for me.
i am really new to VBA would not know how to use the above code on the sheet,
would you kindly be able to help me with the sample book i have attached please.

Training Matrix Sample V1.xlsm

drive.google.com

Thank you once again for all your kindness.

 

[Logit]

.
With your current layout design ... neither macro will work unless it is greatly edited ... or you greatly re-design your current layout to that shown at the botton
of my last post. I am certain that is not your preference.

Let me think about this for awhile ....

 

[hsolanki]

Hi Logit unfortunately i have to use the standards company format and the layout design as it is same cross the whole company. is there any alternative way to come around. the sheet is with conditional format with 90 days notification of color changing. perhaps is there any other way to send email whenever any cells changes the color to Pink and email contains with the name and type of training it going to expire. to each department e.g. Email 1 or Email 2 or Email 3 depending what training is going to expire.

Thank you once again, and no problem Thank you i look forward to hear from you.

 

[Logit]

.
Took awhile to get my head around the process. Hopefully this will accomplish your goals :

Option Explicit

Sub CheckColurRows()
'On Error Resume Next

Dim myRange As Range
Dim cl As Range
Dim ws As Worksheet, ws1 As Worksheet
Dim destRow As Long

Set ws = Worksheets("TrainingMatrix")
Set ws1 = Worksheets("EmailReport")
Set myRange = ws.Range("A1:Z35") 'Set range

ws1.Range("A9:AN36").EntireRow.Delete

destRow = 9
On Error Resume Next
For Each cl In myRange 'Loop through each cell in "myRange

    If cl.Interior.Color = RGB(255, 0, 0) Then 'Check if cell only has red colour
        cl.EntireRow.Copy Sheets("EmailReport").Cells(destRow, 1)
        Sheets("EmailReport").Cells(Cells.Rows.Count, "A").End(xlUp).Offset (1)
        
        destRow = destRow + 1
    
    End If
  
Next cl

ws1.Range("AA9:AN36").Delete

End Sub


Sub CopyRows()
Dim i As Integer
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Sheets("EmailReport")
    ws1.Range("A1:Z35").Copy
    Mail_Selection_Range_Outlook_Body
End Sub

Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim lEndRow
Dim Value As String
Set rng = Nothing
' Only send the visible cells in the selection.
Set rng = Sheets("EmailReport").Range("A1:Z35")
If rng Is Nothing Then
    MsgBox "An unknown error has occurred. "
    Exit Sub
End If
With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
    .To = "Your email address here in quotes"
    .CC = ""
    .BCC = ""
    .Subject = "Summary Data"

    .HTMLBody = "<p>Text above Excel cells" & "<br><br>" & _
                RangetoHTML(rng) & "<br><br>" & _
                "Text below Excel cells.</p>"
    '.Attachments.Add (Application.ActiveWorkbook.FullName)
    ' In place of the following statement, you can use ".Display" to
    ' display the e-mail message.
    .Display
End With
On Error GoTo 0
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Download workbook : Training Matrix Sample V1.xlsm

 

[Logit]

.
One thing you'll need to correct somehow is the RED fill color for the affected cell.

For some reason, the red color selected in the CONDITIONAL FORMAT is not recognized as red ... even though it IS RED and complies with the RGB color code of (255, 0, 0).
When I manually changed the red cells by using the FORMAT menu on right click ( FILL ), that red is recognized.

I don't have an answer why your project is acting this way.

 

[hsolanki]

Good Morning Logit First of all i would like to really appreciate for the work and the code you have put together.

i still got an problem.

1st - when i try to run the report it will show all cells which are highlighted red in EmailReport however email wont open.

2nd issue that it will copy all the rest of the columns which are not highlighted in red, is it possible that only the names and column which has red cells in and send an email?

can we change the color or change to date if anything more than +60 days from the expiry date?

Thank you once again for all your kindness

 

[hsolanki]

Hi Sorry perhaps can it be changed to date +60days from today (<= Date +60) and can it only be email only the column that has 60days + from today date as attached sample image. i am sorry once again and thank you