Send email with rows based on expiration date

M

Musto85

New Member
Joined
Mar 6, 2022
Messages
21
Platform
  1. Windows
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!!!

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
 

Attachments

  • Capture.JPG
    Capture.JPG
    48.1 KB · Views: 21

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
function sendEmails() {
// Get the current date and 14 days from now
var today = new Date();
var twoWeeksFromNow = new Date(today.getTime() + 14 * 24 * 60 * 60 * 1000);

// Get all rows in the sheet that have an expiration date within the next 14 days
var sheet = SpreadsheetApp.getActiveSheet();
var data = sheet.getDataRange().getValues();
var rows = [];
for (var i = 0; i < data.length; i++) {
var expirationDateE = new Date(data[4]); // Column E
var expirationDateH = new Date(data[7]); // Column H
var expirationDateK = new Date(data[10]); // Column K
if (expirationDateE >= today && expirationDateE < twoWeeksFromNow) {
rows.push(data);
} else if (expirationDateH >= today && expirationDateH < twoWeeksFromNow) {
rows.push(data);
} else if (expirationDateK >= today && expirationDateK < twoWeeksFromNow) {
rows.push(data);
}
}

// Send an email for each row with expiration dates within the next 14 days
for (var i = 0; i < rows.length; i++) {
var row = rows;
var email = row[0]; // Column A
var subject = "Expiration Warning";
var message = "The following item(s) are expiring within the next 14 days:\n\n" +
"Column E: " + row[4] + "\n" +
"Column H: " + row[7] + "\n" +
"Column K: " + row[10] + "\n";
MailApp.sendEmail(email, subject, message);
}
}
 
Upvote 0
VBA Code: 
function sendEmails() {
  // Get the current date and 14 days from now
  var today = new Date();
  var twoWeeksFromNow = new Date(today.getTime() + 14 * 24 * 60 * 60 * 1000);

  // Get all rows in the sheet that have an expiration date within the next 14 days
  var sheet = SpreadsheetApp.getActiveSheet();
  var data = sheet.getDataRange().getValues();
  var rows = [];
  for (var i = 0; i < data.length; i++) {
    var expirationDateE = new Date(data[i][4]);  // Column E
    var expirationDateH = new Date(data[i][7]);  // Column H
    var expirationDateK = new Date(data[i][10]); // Column K
    if (expirationDateE >= today && expirationDateE < twoWeeksFromNow) {
      rows.push(data[i]);
    } else if (expirationDateH >= today && expirationDateH < twoWeeksFromNow) {
      rows.push(data[i]);
    } else if (expirationDateK >= today && expirationDateK < twoWeeksFromNow) {
      rows.push(data[i]);
    }
  }

  // Send an email for each row with expiration dates within the next 14 days
  for (var i = 0; i < rows.length; i++) {
    var row = rows[i];
    var email = row[0];  // Column A
    var subject = "Expiration Warning";
    var message = "The following item(s) are expiring within the next 14 days:\n\n" +
                  "Column E: " + row[4] + "\n" +
                  "Column H: " + row[7] + "\n" +
                  "Column K: " + row[10] + "\n";
    MailApp.sendEmail(email, subject, message);
  }
}
 
Upvote 0
hydraulicwave said:
VBA Code: 
function sendEmails() {
  // Get the current date and 14 days from now
  var today = new Date();
  var twoWeeksFromNow = new Date(today.getTime() + 14 * 24 * 60 * 60 * 1000);

  // Get all rows in the sheet that have an expiration date within the next 14 days
  var sheet = SpreadsheetApp.getActiveSheet();
  var data = sheet.getDataRange().getValues();
  var rows = [];
  for (var i = 0; i < data.length; i++) {
    var expirationDateE = new Date(data[i][4]);  // Column E
    var expirationDateH = new Date(data[i][7]);  // Column H
    var expirationDateK = new Date(data[i][10]); // Column K
    if (expirationDateE >= today && expirationDateE < twoWeeksFromNow) {
      rows.push(data[i]);
    } else if (expirationDateH >= today && expirationDateH < twoWeeksFromNow) {
      rows.push(data[i]);
    } else if (expirationDateK >= today && expirationDateK < twoWeeksFromNow) {
      rows.push(data[i]);
    }
  }

  // Send an email for each row with expiration dates within the next 14 days
  for (var i = 0; i < rows.length; i++) {
    var row = rows[i];
    var email = row[0];  // Column A
    var subject = "Expiration Warning";
    var message = "The following item(s) are expiring within the next 14 days:\n\n" +
                  "Column E: " + row[4] + "\n" +
                  "Column H: " + row[7] + "\n" +
                  "Column K: " + row[10] + "\n";
    MailApp.sendEmail(email, subject, message);
  }
}
Click to expand...
Thanks! I’ll try that in a bit. This macro will be called upon the opening of the workbook every Monday, I have a code for that already. Could the code be changed for the sheet in question and not activesheet?
 
Upvote 0
hydraulicwave said:
VBA Code: 
function sendEmails() {
  // Get the current date and 14 days from now
  var today = new Date();
  var twoWeeksFromNow = new Date(today.getTime() + 14 * 24 * 60 * 60 * 1000);

  // Get all rows in the sheet that have an expiration date within the next 14 days
  var sheet = SpreadsheetApp.getActiveSheet();
  var data = sheet.getDataRange().getValues();
  var rows = [];
  for (var i = 0; i < data.length; i++) {
    var expirationDateE = new Date(data[i][4]);  // Column E
    var expirationDateH = new Date(data[i][7]);  // Column H
    var expirationDateK = new Date(data[i][10]); // Column K
    if (expirationDateE >= today && expirationDateE < twoWeeksFromNow) {
      rows.push(data[i]);
    } else if (expirationDateH >= today && expirationDateH < twoWeeksFromNow) {
      rows.push(data[i]);
    } else if (expirationDateK >= today && expirationDateK < twoWeeksFromNow) {
      rows.push(data[i]);
    }
  }

  // Send an email for each row with expiration dates within the next 14 days
  for (var i = 0; i < rows.length; i++) {
    var row = rows[i];
    var email = row[0];  // Column A
    var subject = "Expiration Warning";
    var message = "The following item(s) are expiring within the next 14 days:\n\n" +
                  "Column E: " + row[4] + "\n" +
                  "Column H: " + row[7] + "\n" +
                  "Column K: " + row[10] + "\n";
    MailApp.sendEmail(email, subject, message);
  }
}
Click to expand...


I can't get this to work. Where shall I put this function?
Thanks
 
Upvote 0
hydraulicwave said:
This is a function you will need to run, it's not auto...
Click to expand...

I can't seem to make that work, shall I add this function at the bottom of the code I already had?
Sorry hydraulicwave but I am not a vba expert...
Could you explain please?
 
Upvote 0
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
        
        ' check for expiration date in column H
        If IsDate(ws.Cells(i, "H")) Then
            dtDue = ws.Cells(i, "H")
            iDays = DateDiff("d", Date, dtDue)
            sStatus = ws.Cells(i, "I")
            'dtTimestamp = ws.Cells(i, "J")
            'ws.Cells(i, "X") = iDays
    
            If iDays > 0 And iDays < 14 And sStatus <> "Sent"
 
Upvote 0
hydraulicwave said:
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
       
        ' check for expiration date in column H
        If IsDate(ws.Cells(i, "H")) Then
            dtDue = ws.Cells(i, "H")
            iDays = DateDiff("d", Date, dtDue)
            sStatus = ws.Cells(i, "I")
            'dtTimestamp = ws.Cells(i, "J")
            'ws.Cells(i, "X") = iDays
   
            If iDays > 0 And iDays < 14 And sStatus <> "Sent"
Click to expand...


There's a part missing????
 
Upvote 0
Musto85 said:
There's a part missing????
Click to expand...


I've managed to get it to work, however they're all in one table which the result is a bit confusing.

Would it be possible to have the matching rows for criteria in row H in a table and those ones for row K on another table both in the same email?
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
VBA for sending rows of data if column A = current date. (Via email)
Replies
1
Views
398
paun_shotts
P
2
  • Question
VBA Copy Data from Sheet to Email depending on Assignee
Replies
2
Views
357
2000km12
2
E
  • Question
Adding a custom message.
Replies
1
Views
439
Micron
M
2
  • Solved
Copy table to email error
Replies
3
Views
384
Alex Blakenburg
A
Antonio Costa
  • Solved
VBA to automate sending emails and copy date/time and subject for other sheet
Replies
3
Views
510
DanteAmor
DanteAmor

Forum statistics

Threads
1,215,198
Messages
6,123,589
Members
449,109
Latest member
Sebas8956

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top