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
chris pikeAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Ryan ChongCommented:
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

Open in new window

Q_28733860-RevA_b.xlsm
0
kgerbChief EngineerCommented:
Hello Chris,
Sorry for the delay.  I didn't have time to work on this last night.  Please take a look at the attached file.  It has a "dashboard" page where you enter the names of all the managers.  I also added a column to the expiration date table for the supervisor name.  Don't remove this column, it needs to be there.  To add more managers just add them to the bottom of the list on the dashboard sheet.

Kyle
Q_28733860-RevB.xlsm
1

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
chris pikeAuthor Commented:
Looking now thanks Kyle
0
chris pikeAuthor Commented:
Kyle,
I lest you a private message, did you get it???
Thanks
Chris
0
chris pikeAuthor Commented:
Awesome help on this project. Very helpful and quick turn around.
Very much appreciated.
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.