30 days prior date popup notificationClosed

Question

Hello, 
I've currently done condition formatting on the expiry date column to turn RED 30 days prior to expiry using formula =AND($H2>TODAY(),$H2-TODAY()<=30)

I would also like to have a pop up window that alerts me of the same. so when window pops up exactly 30 days prior I see which cell is turned RED and work on renewing that.
Any advice is greatly appreciated. Thanks!

vcoolio · Answer

Hello Filliords,

Try the following code placed into the ThisWorkbook module:-

Private Sub Workbook_Open()

Dim c As Range, msg As String, sh As Worksheet, rng As Range
        Set sh = Sheet1
        Set rng = sh.Range("H2", sh.Range("H" & sh.Rows.Count).End(xlUp))
        
        For Each c In rng
                If c.Value <> [Today()+30] Then GoTo next_c
next_c:
                If c.Value = [Today()+30] Then
                       msg = msg & vbLf & Chr(149) & c.Address
                End If
        Next c
        
        If msg = vbNullString Then
            MsgBox "Nothing expiring yet.", vbExclamation
        Else
            MsgBox msg, vbInformation, "The following cell dates are due to expire in 30 days' time."
        End If
        
End Sub

This is a Workbook_Open event code and will trigger each time the workbook is opened.

To implement this code:-

- Right click on a sheet tab.
- Select "View Code" from the menu that appears. This opens the VB Editor.
- Over to the left in the Project Explorer, double click on ThisWorkbook.
- In the big white code field to the right of the Project Explorer, paste the above code.
- Save the workbook with an .xlsm file extension.

Test the code in a copy of your actual workbook.

I hope that this helps.

Cheerio,
vcoolio.

filliords · Answer

hi, thanks for getting back. I did placed the code as instructed but I am not getting the notification for dates expiring within 30 days. It does say when workbook is opened "Nothing expiring yet". However, there are cells that are expiring within 30 days. Please let me know if anything needs to be modified. Thanks!

vcoolio · Answer

Hello Filliords,

https://wetransfer.com/downloads/390169a287bcd0e22e3f0aa1226a5a1c20220119012447/13f9f9

At the above link, I've attached a sample file which shows that the code works as it should.
In Column H of the sample, there are two dates in red font (18/02/2022), day/month/year format, which are due to expire in thirty days' time. On opening the sample workbook, a message box will pop up showing the relevant cell references.
Please note that the dates are set in my time zone so you may have to adjust the sample to suit your own time zone. Do so if you need to but ensure to save then close the workbook before re-opening it.
The only other reason I can think of as to why it didn't work for you is that the sheet reference might not be correct. I have used the sheet code (Sheet1) in the macro which is defined by line 4 in my post #1. Check this in the Project Explorer and alter it if need be or change the value of the variable from:

Set sh = Sheet1

to 

Set sh = Sheets("Whatever your sheet name").

Cheerio,
vcoolio.

filliords · Answer

Hi Cheerio, thanks for your input. Yes it is working now. Not sure what happened before. How can i imply the same rules on sheet 2 and other sheets? Please let me know when possible. Thanks!

vcoolio · Answer

Hello Filliords,

Perhaps this:-

Private Sub Workbook_SheetActivate(ByVal Sh As Object)

Dim c As Range, msg As String, rng As Range
        Set rng = Sh.Range("H2", Sh.Range("H" & Sh.Rows.Count).End(xlUp))
        
        For Each c In rng
                If c.Value <> [Today()+30] Then GoTo next_c
next_c:
                If c.Value = [Today()+30] Then
                       msg = msg & vbLf & Chr(149) & Sh.Name & " " & c.Address
                End If
        Next c
       
        If msg = vbNullString Then
            MsgBox "Nothing expiring yet.", vbExclamation
        Else
            MsgBox msg, vbInformation, "Dates in the following cells are due to expire in 30 days' time."
        End If
End Sub

Paste it directly below the existing code in the ThisWorkbook module. Save and close the workbook (ensure that you have saved it with the .xlsm file extension).
You'll receive the pop up on opening the workbook (Sheet1) and when you click on another sheet tab to open it, you'll receive the same message for that sheet. Any sheet will then be covered by this additional code.

I hope that this helps.

Cheerio,
vcoolio.

30 days prior date popup notification

5 responses

Similar discussions

Subscribe To Our Newsletter!