asked on 9/30/2015

Excel to Outlook for expiry dates (additional Help required)

Hi there I need help with the VB.

I need to be able to add more additional entries at the bottom of the list.
I also would love it if this code could work for each sheet, so i can categorize each type of data per worksheet.

here is the code
Sub RunExpReport()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
Dim rng As Range
Dim EmailTo As String
Dim DaysBefore As Long
Dim TodayLong As Long
Dim sBody As String
Dim OutApp As Object
Dim OutMail As Object

TodayLong = Now
DaysBefore = Range("DaysBeforeExp")
EmailTo = Range("EmailAddress")
sBody = "Here is the expiration report as of " & Format(Now, "yyyy/mm/dd") & vbNewLine

For Each rng In Range("ExpDates")
If TodayLong + DaysBefore >= DateValue(rng) And DateValue(rng) > TodayLong Then
sBody = sBody & vbNewLine & rng.Offset(, -2) & " " & rng.Offset(, -1) & " " & Format(rng, "yyyy/mm/dd")
End If
Next rng

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

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = EmailTo
.CC = ""
.BCC = ""
.Subject = "Expiration Date Report as of " & Format(Now, "yyyy/mm/dd")
.body = sBody
'.Send 'use this instead of .display if you want
.display
End With

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
End Sub

Here is spreadsheet
Q_28733860-RevA.xlsm

Outlook Microsoft Excel

Last Comment

chris pike

10/1/2015

Ryan Chong

9/30/2015

you can try loop through all your worksheets by adding:

For Each ws In ThisWorkbook.Sheets
'.....
Next

for example, try customize this...

Sub RunExpReport()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
    Dim rng As Range
    Dim EmailTo As String
    Dim DaysBefore As Long
    Dim TodayLong As Long
    Dim sBody As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Sheets
    
        TodayLong = Now
        DaysBefore = ws.Range("DaysBeforeExp")
        EmailTo = ws.Range("EmailAddress")
        sBody = "Here is the expiration report as of " & Format(Now, "yyyy/mm/dd") & vbNewLine
    
        For Each rng In ws.Range("ExpDates")
            If TodayLong + DaysBefore >= DateValue(rng) And DateValue(rng) > TodayLong Then
                sBody = sBody & vbNewLine & rng.Offset(, -2) & "    " & rng.Offset(, -1) & "    " & Format(rng, "yyyy/mm/dd")
            End If
        Next rng
        
        With Application
            .EnableEvents = False
            .ScreenUpdating = False
        End With
    
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
    
        On Error Resume Next
        With OutMail
            .To = EmailTo
            .CC = ""
            .BCC = ""
            .Subject = "Expiration Date Report as of " & Format(Now, "yyyy/mm/dd")
            .body = sBody
            '.Send 'use this instead of .display if you want
            .display
        End With
    
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    
        Set OutMail = Nothing
        Set OutApp = Nothing
    
    Next
End Sub