VBA for sending rows of data if = current date. (Via email)

SnailTerminator

New Member
Joined
Jan 24, 2021
Messages
7
Office Version
  1. 2013
Platform
  1. Windows
Hi all.

Wonder if anyone could advise.

I have this spreadsheet that I am trying to automate so it sends an email containing the rows that meet the criteria of today's date. I do have a basic code, but unfortunately I have two problems.

1) I can only seem to add one cell from the selected row (but I need all the relevant information from columns B-G).
2) If multiple rows meet the current date it generates multiple emails (I just need the one email but with the multiple rows below each other).

I am new to VBA and coding in general so any help would be greatly appreciated.

Here's the code and see below a picture of the sheet.

Private Sub Workbook_Open()
Dim OutApp As Object
Dim OutMail As Object
Dim lLastRow As Long
Dim lRow As Long
Dim sSendTo As String
Dim sSendCC As String
Dim sSendBCC As String
Dim sSubject As String
Dim sTemp As String

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

' Change the following as needed
sSendTo = ""
sSendCC = ""
sSendBCC = ""
sSubject = "Due date reached"

lLastRow = Cells(Rows.Count, 3).End(xlUp).Row
For lRow = 2 To lLastRow
If Cells(lRow, 11) = "S" Then
If Cells(lRow, 1) = Date Then
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = sSendTo
If sSendCC > "" Then .CC = sSendCC
If sSendBCC > "" Then .BCC = sSendBCC
.Subject = sSubject

sTemp = "Hello!" & vbCrLf & vbCrLf
sTemp = sTemp & "The due date has been reached "
sTemp = sTemp & "for this project:" & vbCrLf & vbCrLf
' Assumes project name is in column B
sTemp = sTemp & " " & Cells(lRow, 2)
sTemp = sTemp & "Please take the appropriate"
sTemp = sTemp & "action." & vbCrLf & vbCrLf
sTemp = sTemp & "Thank you!" & vbCrLf

.Body = sTemp
' Change the following to .Send if you want to
' send the message without reviewing first
.Display
End With
Set OutMail = Nothing

Cells(lRow, 11) = "S"
Cells(lRow, 12) = "E-mail sent on: " & Now()
End If
End If
Next lRow
Set OutApp = Nothing
End Sub
 

Attachments

  • Screenshot (3).png
    Screenshot (3).png
    106.3 KB · Views: 14

Some videos you may like

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,891
Office Version
  1. 2013
Platform
  1. Windows
Hi,

try the following. It uses autofilter to filter rows for todays date in column A.
It copies the filtered rows with the header to a new worksheet - MailBody
The content of that sheet is set as a range only columns B to G then Using the RangetoHTML function it is copied to Outlook retaining the table formatting
but only ten columns are sent

If a mail is sent column K gets a yes added and L the date.
The yes is checked for so that 2 mails can't be sent on the same day.

Code:
Sub Send_Table_autofilter_2()

Dim MailBody As Range
Dim dwn As Range

'If filtered remove filter. Throws error if not filtered
  ActiveSheet.Range("A2").Activate
  On Error Resume Next
  ActiveSheet.ShowAllData

Set mWs = Worksheets("Sheet5")

'If MailBody sheet already exists then delete it
  If WorksheetExists("MailBody") Then
   Application.DisplayAlerts = False
    Worksheets("MailBody").Delete
   Application.DisplayAlerts = True
End If

'Add a sheet to copy all todays date rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "MailBody"
 

'Return to the mail content sheet
   mWs.Activate

'Set range as column A to check for todays date. If yes is found skip filter and mail creation
Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
          
    For Each cell In rng
    If cell.Value = Date Then
    If Not cell.Offset(0, 10).Value = "yes" Then
   
   
'https://stackoverflow.com/questions/52340156/excel-macro-to-filter-column-to-todays-date
  With Worksheets("Sheet5")
    With rng
    .AutoFilter field:=1, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
    End With
   End With
      
'Copy the autofilter range and header to the MailBody sheet
    Worksheets("Sheet5").AutoFilter.Range.Offset(0, 0).Copy Sheets("MailBody").Range("A1")
  
   
'Need to add yes to each autofiltered row and date. Column A is the range so offset by 10 and 11 columns.
    For Each dwn In rng.SpecialCells(xlCellTypeVisible)
    rng.Offset(0, 10).Value = "yes"
    rng.Offset(0, 11).Value = Date
    Next
   
   
   ActiveSheet.Range("A2").Activate
   ActiveSheet.ShowAllData
              

' Change the following as needed
    sSendTo = "JoeBloggs@yahoo.co.uk"
    sSendCC = ""
    sSendBCC = ""
    sSubject = "Due date reached"
      
MsgStr = sTemp = "Hello!" & "<br><br>"
         sTemp = sTemp & "The due date has been reached "
         sTemp = sTemp & "for this project:" & "<br><br>"
' Assumes project name is in column B
         sTemp = sTemp & " " & Cells(lRow, 2)
         sTemp = sTemp & "Please take the appropriate"
         sTemp = sTemp & "action." & "<br><br>"
         sTemp = sTemp & "Thank you!" & "<br>"


'Set Range on MailBody Sheet, then autofit it before copying to mail
  With Worksheets("MailBody")
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    
 Set MailBody = .Range(.Cells(1, 2), .Cells(lRow, 7)) 'Columns 2 to 7
'Set MailBody = .Range(.Cells(1, 1), .Cells(lRow, 10)) - Columns 1 to 10
  End With
 
  MailBody.Columns.AutoFit
   
                      
'Create mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
   
        With OutMail
            .To = sSendTo
            .CC = sSendCC
            .Subject = sSubject
            .HTMLBody = sTemp & RangetoHTML(MailBody)
            .Display
        'send
       End With
          
          
  End If
End If


MailTo = ""
MailSubject = ""
Next


'Delete MailBody sheet
Application.DisplayAlerts = False
' Worksheets("MailBody").Delete
Application.DisplayAlerts = True
End Sub


Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
'Function from - https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

    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 -4163, , False, False
        .Cells(1).PasteSpecial -4122, , 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:=4, _
         filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=0)
        .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

'Does the worksheet exists
    Function WorksheetExists(WSName) As Boolean
        On Error Resume Next
        WorksheetExists = Worksheets(WSName).Name = WSName
    On Error GoTo 0
    End Function
 
Last edited:
Solution

SnailTerminator

New Member
Joined
Jan 24, 2021
Messages
7
Office Version
  1. 2013
Platform
  1. Windows
Hi,

try the following. It uses autofilter to filter rows for todays date in column A.
It copies the filtered rows with the header to a new worksheet - MailBody
The content of that sheet is set as a range only columns B to G then Using the RangetoHTML function it is copied to Outlook retaining the table formatting
but only ten columns are sent

If a mail is sent column K gets a yes added and L the date.
The yes is checked for so that 2 mails can't be sent on the same day.

Code:
Sub Send_Table_autofilter_2()

Dim MailBody As Range
Dim dwn As Range

'If filtered remove filter. Throws error if not filtered
  ActiveSheet.Range("A2").Activate
  On Error Resume Next
  ActiveSheet.ShowAllData

Set mWs = Worksheets("Sheet5")

'If MailBody sheet already exists then delete it
  If WorksheetExists("MailBody") Then
   Application.DisplayAlerts = False
    Worksheets("MailBody").Delete
   Application.DisplayAlerts = True
End If

'Add a sheet to copy all todays date rows to
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "MailBody"


'Return to the mail content sheet
   mWs.Activate

'Set range as column A to check for todays date. If yes is found skip filter and mail creation
Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
        
    For Each cell In rng
    If cell.Value = Date Then
    If Not cell.Offset(0, 10).Value = "yes" Then
 
 
'https://stackoverflow.com/questions/52340156/excel-macro-to-filter-column-to-todays-date
  With Worksheets("Sheet5")
    With rng
    .AutoFilter field:=1, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
    End With
   End With
    
'Copy the autofilter range and header to the MailBody sheet
    Worksheets("Sheet5").AutoFilter.Range.Offset(0, 0).Copy Sheets("MailBody").Range("A1")

 
'Need to add yes to each autofiltered row and date. Column A is the range so offset by 10 and 11 columns.
    For Each dwn In rng.SpecialCells(xlCellTypeVisible)
    rng.Offset(0, 10).Value = "yes"
    rng.Offset(0, 11).Value = Date
    Next
 
 
   ActiveSheet.Range("A2").Activate
   ActiveSheet.ShowAllData
            

' Change the following as needed
    sSendTo = "JoeBloggs@yahoo.co.uk"
    sSendCC = ""
    sSendBCC = ""
    sSubject = "Due date reached"
    
MsgStr = sTemp = "Hello!" & "<br><br>"
         sTemp = sTemp & "The due date has been reached "
         sTemp = sTemp & "for this project:" & "<br><br>"
' Assumes project name is in column B
         sTemp = sTemp & " " & Cells(lRow, 2)
         sTemp = sTemp & "Please take the appropriate"
         sTemp = sTemp & "action." & "<br><br>"
         sTemp = sTemp & "Thank you!" & "<br>"


'Set Range on MailBody Sheet, then autofit it before copying to mail
  With Worksheets("MailBody")
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
  
Set MailBody = .Range(.Cells(1, 2), .Cells(lRow, 7)) 'Columns 2 to 7
'Set MailBody = .Range(.Cells(1, 1), .Cells(lRow, 10)) - Columns 1 to 10
  End With

  MailBody.Columns.AutoFit
 
                    
'Create mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
 
        With OutMail
            .To = sSendTo
            .CC = sSendCC
            .Subject = sSubject
            .HTMLBody = sTemp & RangetoHTML(MailBody)
            .Display
        'send
       End With
        
        
  End If
End If


MailTo = ""
MailSubject = ""
Next


'Delete MailBody sheet
Application.DisplayAlerts = False
' Worksheets("MailBody").Delete
Application.DisplayAlerts = True
End Sub


Function RangetoHTML(rng As Range) ' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
'Function from - https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

    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 -4163, , False, False
        .Cells(1).PasteSpecial -4122, , 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:=4, _
         filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=0)
        .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

'Does the worksheet exists
    Function WorksheetExists(WSName) As Boolean
        On Error Resume Next
        WorksheetExists = Worksheets(WSName).Name = WSName
    On Error GoTo 0
    End Function
Christ on a bike. Thank you so much for this. It's a project for work so will have to try it tomorrow and see.
 

SnailTerminator

New Member
Joined
Jan 24, 2021
Messages
7
Office Version
  1. 2013
Platform
  1. Windows
Christ on a bike. Thank you so much for this. It's a project for work so will have to try it tomorrow and see.
Hi again,

Tried the code and it works exactly as I wanted. Can't thank you enough.

I will be cheeky if I may and just ask if this would work if I had a different email address assigned for different sheets in the workbook (assuming I change the appropriate bits of the code accordingly)?

Cheers,
Kane
 

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,891
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

There's no reason it can't be modified to work with the current ActiveSheet.

I assume each sheet has similar data to filter and email and that there's an email address associated with that sheet? Is that stored anywhere on the sheet?

You could then use something like Select Case Activesheet.Name to determine which email address to set sSendTo as.

I can look at this Thursday if you get stuck.
 

SnailTerminator

New Member
Joined
Jan 24, 2021
Messages
7
Office Version
  1. 2013
Platform
  1. Windows
There's no reason it can't be modified to work with the current ActiveSheet.

I assume each sheet has similar data to filter and email and that there's an email address associated with that sheet? Is that stored anywhere on the sheet?

You could then use something like Select Case Activesheet.Name to determine which email address to set sSendTo as.

I can look at this Thursday if you get stuck.
Hi,

Thanks for your reply.

Each sheet has exactly the same layout, and there is an email associated with each sheet (not currently in a cell in the sheet itself but could be easily input- although having said that only one email address can be associated to the one sheet).

I will have a look into it now.

And thank you very much for the offer but I can't take anymore of your time. You have been brilliant.
 

SnailTerminator

New Member
Joined
Jan 24, 2021
Messages
7
Office Version
  1. 2013
Platform
  1. Windows

ADVERTISEMENT

Hi again,

Sorry about this ..... but I have had a look into changing the code so that it has a different email associated with the sheet. It generates an email with the sTemp text, however it doesn't include the table - aka mailbody (it still works fine for the first sheet). Also I know that it is looking at the appropriate sheet as I have changed the dates so it would only trigger for sheet two.

Ultimately I intend to have a Worksheet VBA that runs the codes one after another after the sheet has been saved. (Got the code for that and it works - but like I say it doesn't input the table in the second email). Any suggestions?

Also another problem I am having due to management changing the goal posts is it needs to go from a shared mailbox .net account which we access online rather than on the outlook application. Is this even possible? - As in does the SendOnBehalfOf encrypt the data based on the email address, or the does it bypass that? (This is not a problem in my eyes as if necessary I will just anonymize the data).

I am terribly sorry for the update in all of my questions.

Regards,
Kane
 

daverunt

Well-known Member
Joined
Jul 9, 2009
Messages
1,891
Office Version
  1. 2013
Platform
  1. Windows
Hi

without seeing your code I can only surmise what the issue is likely to be.
Firstly I have used a loop to activate each sheet in the workbook in turn and get its name for the autofilter. -- This area is probably where your issue is.
Compare what your code is doing to what's posted below.

I have used Select case for the emails, as I don't know how you are doing it.

As to the query re sending it from the online .net account. Personally I doubt it but its worth asking in another thread but you'll have to give more details of the type of account.

You are using Outlook to generate and send the mail. You might be able to use the online mailbox address in SentonBehalfof to indicate it comes from the online address but if that's just a name like "SharedMail" encapsulating a list of recipients then Outlook will flag it up as unrecognised, unless that shared mailbox is recognised as an Outlook account on your PC.

It's simple enough to test SentonBehalfof by sending some mails to yourself.

The other thing I missed is turning off the autofilter on the table once finished with. If you need to do that here's a good example.


Code:
Sub Send_Table_autofilter_2()

Dim MailBody As Range
Dim dwn As Range
Dim ws As Worksheet

For Each ws In Worksheets


  ws.Activate

'I use this variable later for the autofilter as it needs the worksheet name
  wsNme = ws.Name

Select Case ActiveSheet.Name

Case Is = "Sheet5"
SendTo = "Fred@yahoo.com"

Case Is = "Sheet10"
SendTo = "Dave@gmail.com"

End Select


'If filtered remove filter. Throws error if not filtered
  ActiveSheet.Range("A2").Activate
  On Error Resume Next
  ActiveSheet.ShowAllData

 Set mWs = ActiveSheet

'If MailBody sheet already exists then delete it
  If WorksheetExists("MailBody") Then
   Application.DisplayAlerts = False
    Worksheets("MailBody").Delete
   Application.DisplayAlerts = True
 End If
 
'Add a sheet to copy all todays date rows to
 Sheets.Add(After:=Sheets(Sheets.Count)).Name = "MailBody"
  

 'Return to the mail content sheet
   mWs.Activate

'Set range as column A to check for todays date. If yes is found skip filter and mail creation
 Set rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
           
    For Each cell In rng
    If cell.Value = Date Then
    If Not cell.Offset(0, 10).Value = "yes" Then
    
    
'https://stackoverflow.com/questions/52340156/excel-macro-to-filter-column-to-todays-date
  With ActiveWorksheet
    With rng
    .AutoFilter field:=1, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
    End With
   End With
       
 'Copy the autofilter range and header to the MailBody sheet
 'Either of the following works:
 'I created the wsNme after activating each sheet but that's not necessary if you use the conmmented out line below
 
   'Worksheets(ActiveSheet.Name).AutoFilter.Range.Offset(0, 0).Copy Sheets("MailBody").Range("A1")
    Worksheets(ws.Name).AutoFilter.Range.Offset(0, 0).Copy Sheets("MailBody").Range("A1")
   
    
'Need to add yes to each autofiltered row and date. Column A is the range so offset by 10 and 11 columns.
    For Each dwn In rng.SpecialCells(xlCellTypeVisible)
    rng.Offset(0, 10).Value = "yes"
    rng.Offset(0, 11).Value = Date
    Next
    
    
   ActiveSheet.Range("A2").Activate
   ActiveSheet.ShowAllData
               

' Change the following as needed
    sSendTo = SendTo
    sSendCC = ""
    sSendBCC = ""
    sSubject = "Due date reached"
       
sTemp = "Hello!" & "<br><br>"
         sTemp = sTemp & "The due date has been reached "
         sTemp = sTemp & "for this project:" & "<br><br>"
' Assumes project name is in column B
         sTemp = sTemp & " " & Cells(lRow, 2)
         sTemp = sTemp & "Please take the appropriate"
         sTemp = sTemp & "action." & "<br><br>"
         sTemp = sTemp & "Thank you!" & "<br>"


'Set Range on MailBody Sheet, then autofit it before copying to mail
  With Worksheets("MailBody")
    lRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Set MailBody = .Range(.Cells(1, 2), .Cells(lRow, 7))
  End With
  
  MailBody.Columns.AutoFit
    
                       
'Create mail
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
        With OutMail
            .To = sSendTo
            .SentOnBehalfOfName = "john@yahoo.com" 'a valid email address format
            .CC = sSendCC
            .Subject = sSubject
            .HTMLBody = sTemp & RangetoHTML(MailBody)
            .Display
        'send
       End With
           
           
  End If
 End If
 
 
MailTo = ""
MailSubject = ""
Next

'Delete MailBody sheet
 Application.DisplayAlerts = False
 Worksheets("MailBody").Delete ' You could clear the contents here instead of deleting the sheet.
 'Then move this to below the next so it deletes the MailBody sheet after all of them processed.
 Application.DisplayAlerts = True
Next
 
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,127,405
Messages
5,624,574
Members
416,036
Latest member
eloisa manzanarez

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
Top