Hi all, I have the code below that send an automatic email based on the expiration date in column E. (anything 14 days ahead of today’s date)
Can someone help me as I would like also in the same email to include all those rows with the same criteria (14 days) approaching for exp. date in column H and column K?
If possible it would be great to have them in the same email but in separate tables (three separate tables)
Thanks in advance!!!
Can someone help me as I would like also in the same email to include all those rows with the same criteria (14 days) approaching for exp. date in column H and column K?
If possible it would be great to have them in the same email but in separate tables (three separate tables)
Thanks in advance!!!
VBA Code:
Option Explicit
Sub Send_Table_autofilter_2()
Dim wb As Workbook, ws As Worksheet, wsBody As Worksheet
Dim rng As Range, dtDue As Date, iDays As Long
Dim iLastRow As Long, iMailRow As Long, i As Long
Dim sDates As String, dtTimestamp As Date, sStatus As String
Dim lines As New Collection
' delete existing MailBody Sheet
Application.ScreenUpdating = False
Set wb = ThisWorkbook
For Each ws In wb.Sheets
If ws.Name = "MailBody" Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
End If
Next
' create new MailBody Sheet
Set wsBody = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
wsBody.Name = "MailBody"
' header row
Set ws = wb.Worksheets("Probation")
' added header on Mailbody sheet - the same as on Probation
With wsBody.Range("A1:E1")
.Value2 = ws.Range("A1:E1").Value2
.Font.Bold = True
End With
' scan sheet for due in <= 14 days
' copy to MailBody
iMailRow = 1
iLastRow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
For i = 2 To iLastRow
If IsDate(ws.Cells(i, "E")) Then
dtDue = ws.Cells(i, "E")
iDays = DateDiff("d", Date, dtDue)
sStatus = ws.Cells(i, "F")
'dtTimestamp = ws.Cells(i, "G")
'ws.Cells(i, "X") = iDays
If iDays > 0 And iDays < 14 And sStatus <> "Sent" Then
iMailRow = iMailRow + 1
wsBody.Range("A" & iMailRow & ":E" & iMailRow).Value = ws.Range("A" & i & ":E" & i).Value
lines.Add i, CStr(i)
End If
End If
Next
With wsBody
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("D1:D100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A2:E100")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
' check if any records in collection
If lines.Count > 0 Then
' convert to html
sDates = Format(Date, "dd mmm yyyy") & " and " & Format(Date + 14, "dd mmm yyyy")
Call SendEmail(wsBody.UsedRange, sDates)
' record email sent
For i = 1 To lines.Count
ws.Range("F" & lines(i)) = "Sent"
'ws.Range("G" & lines(i)) = Now()
Next
Else
MsgBox "No records due", vbInformation
End If
' delete temp
Application.DisplayAlerts = False
wsBody.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function RangetoHTML(rng As Range) As String
Dim h As String, c As Integer, r As Long
h = "<table cellspacing=""0"" cellpadding=""5"" border=""1"" style=""font:13px Verdana"">"
For r = 1 To rng.Rows.Count
h = h & "<tr>"
For c = 1 To rng.Columns.Count
If r = 1 Then ' header
h = h & "<th bgcolor=" & Chr(34) & "e0e0e0" & Chr(34) & ">" & rng.Cells(1, c) & "</th>"
Else
h = h & "<td>" & rng.Cells(r, c) & "</td>"
End If
Next
h = h & "</tr>"
Next
RangetoHTML = h & "</table>"
End Function
Sub SendEmail(MailBody As Range, sDates As String)
Const CSS = "<style>p{font:13px Verdana};</style>"
Dim msg As String, outApp, outMail
msg = "<p>Hello!" & "<br><br>" & _
"The following are due between " & sDates & _
"<br><br>Please take the appropriate action<br><br>Thank you!<br>"
'Create mail
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)
With outMail
.To = "email@email.com"
.cc = "sSendCC"
.Subject = "Due in next 14 days"
.HTMLBody = CSS & msg & RangetoHTML(MailBody)
.Display
'send
End With
'outApp.Quit
'Set outApp = Nothing
End Sub
