# Send email with rows based on expiration date



## Musto85 (Sunday at 1:18 PM)

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!!!


```
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
```


----------



## hydraulicwave (Sunday at 1:26 PM)

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);
  }
}_


----------



## hydraulicwave (Sunday at 1:27 PM)

```
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);
  }
}
```


----------



## Musto85 (Sunday at 2:12 PM)

hydraulicwave said:


> ```
> function sendEmails() {
> // Get the current date and 14 days from now
> var today = new Date();
> ...


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?


----------



## Musto85 (Sunday at 3:12 PM)

hydraulicwave said:


> ```
> function sendEmails() {
> // Get the current date and 14 days from now
> var today = new Date();
> ...




I can't get this to work. Where shall I put this function?
Thanks


----------



## hydraulicwave (Sunday at 3:20 PM)

This is a function you will need to run, it's not auto...


----------



## Musto85 (Sunday at 7:01 PM)

hydraulicwave said:


> This is a function you will need to run, it's not auto...



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?


----------



## hydraulicwave (Monday at 1:30 PM)

```
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"
```


----------



## Musto85 (Monday at 4:23 PM)

hydraulicwave said:


> ```
> Option Explicit
> Sub Send_Table_autofilter_2()
> Dim wb As Workbook, ws As Worksheet, wsBody As Worksheet
> ...




There's a part missing????


----------



## Musto85 (Monday at 4:55 PM)

Musto85 said:


> There's a part missing????




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?


----------



## Musto85 (Sunday at 1:18 PM)

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!!!


```
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
```


----------



## Musto85 (Monday at 7:36 PM)

I managed to get to the creation of two separate sheets with rows needed but once it gets to the sending of email I get this error message...

On the line : Sub SendEmail(MailBody, MailBody2 As Range, sDates As String)

Message being: ByRef Argument Type Mismatch




```
Option Explicit
Sub Send_Table_autofilter_2()
    Dim wb As Workbook, ws As Worksheet, wsBody, wsBody2 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" or ws.Name = "MailBody2" 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"
    wsBody2.Name = "MailBody2"
    
    ' 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

 With wsBody2.Range("A1:H1")
        .Value2 = ws.Range("A1:H1").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
    
   iMailRow = 1
    iLastRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    For i = 2 To iLastRow
        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" Then
                iMailRow = iMailRow + 1
                wsBody2.Range("A" & iMailRow & ":H" & iMailRow).Value = ws.Range("A" & i & ":H" & 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

With wsBody2
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("D1:D100"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A2:H100")
            .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, wsBody2.UsedRange, sDates)

        ' record email sent
        For i = 1 To lines.Count
            ws.Range("F" & lines(i)) = "Sent"
            ws.Range("I" & 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

[COLOR=rgb(250, 197, 28)]Sub SendEmail(MailBody, MailBody2 As Range, sDates As String)[/COLOR]

   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) & RangetoHTML(MailBody2)
        .Display
        'send
    End With
    'outApp.Quit
    'Set outApp = Nothing

End Sub
```


----------

