VBA code for pop-up messages to notify due dates

[charlie2503]

Hi everyone,

I am new to VBA and am desperate for some help.
I am working on an excel file containing a list of food product certifications. I have multiple columns (L, N, and X) listing the due dates for 3 different certifications.
Certifications 1 and 3 (in columns L and X) need an alert that is 1 year earlier than the listed due date, while certification 2 only needs an alert 6 months earlier.

I have copied a code that creates a pop-up for certification 1 successfully, but how do I apply this for certifications 2 and 3 with due dates listed in different columns?
Also, is it possible use this code if the file has multiple tabs (considering each tab has the 3 different due dates listed in columns L, N, and X as well).

I'm really struggling with this and would appreciate your help.

Here's the code that I use:

Private Sub Workbook_Open()

Dim RegNumberValidUntilCol As Range
Dim RegNumberValidUntil As Range
Dim NotificationMsg As String

Set RegNumberValidUntilCol = Range("L2:L19")

For Each RegNumberValidUntil In RegNumberValidUntilCol

If RegNumberValidUntil <> "" And RegNumberValidUntil - Date <= 365 Then
NotificationMsg = NotificationMsg & " " & RegNumberValidUntil.Offset(0, -9)
End If

Next RegNumberValidUntil

If NotificationMsg = "" Then

MsgBox "You do not have any product registrations expiring soon."

Else: MsgBox "Registrations of the following products are expiring soon: " & NotificationMsg

End If


End Sub

 

[offthelip]

I have written some code to do what you want, I have used much shorter names than you standard just to save a lot oftime on the keyboard . I have defined 5 constants ( some of them arrays) which determine what the code does:

wkstocheck = Array("Sheet1", "Sheet3")  ' this gives a list of the names of the worksheets to check
colnos = Array(12, 14, 24) ' column numbers for columns L , N and X , this is hte list of columns to check for dates assumed to be the same for every worksheet
collimits = Array(365, 184, 365)   ' these are date limits associated with each column i.e column 12 (L) has limit of 365 ,while column 14 (N) has a limit of 184 
lastrow = 19  ' this is the lastrow of data to check
namecol = 3   ' this is the column number of the column you want to appear in the pop up

I have written this a stand alone macor for you to check, when you are happy with you can move it to the worksheet open macro:

'Private Sub Workbook_Open()

Sub test2()

Dim NotificationMsg As String
NotificationMsg = ""
wkstocheck = Array("Sheet1", "Sheet3")
colnos = Array(12, 14, 24) ' column numbers for columns L , N and X
collimits = Array(365, 184, 365)
lastrow = 19
namecol = 3   ' this is the column number of the column you want to appear in the pop up
Dim inarr As Variant

For wks = 1 To Worksheets.Count
 wksname = Worksheets(wks).Name
 For k = 0 To UBound(wkstocheck)
  If wksname = wkstocheck(k) Then   ' process this worksheet
    With Worksheets(wks)
    inarr = .Range(.Cells(1, 1), .Cells(lastrow, colnos(UBound(colnos))))  ' this loads all the worksheet into a variant array up  to the last columns specfied in colnos
    End With
    For j = 0 To UBound(colnos)
        For i = 2 To lastrow
          If inarr(i, colnos(j)) <> "" And inarr(i, colnos(j)) - Date <= collimits(j) Then
            NotificationMsg = NotificationMsg & wksname & ":" & inarr(i, namecol) & ", " 'add  worksheet name and space and comma for clarity
          End If
        Next i
    Next j
  End If
 Next k
Next wks
If NotificationMsg = "" Then

MsgBox "You do not have any product registrations expiring soon."

Else
 NotificationMsg = Left(NotificationMsg, Len(NotificationMsg) - 2)  ' Take off the last space and commma
 MsgBox "Registrations of the following products are expiring soon: " & NotificationMsg

End If

End Sub

 

[charlie2503]

Thank you so much for your help. I really appreciate it. I changed "sheet3" into "sheet1" and lastrow=40 since one of the sheet's data reaches row 40. However, no pop-up shows when I open the file. There are no warning or error signs so I'm not sure what's wrong with it.

 

[charlie2503]

Thank you so much for your help. I really appreciate it. I changed "sheet3" into "sheet1" and lastrow=40 since one of the sheet's data reaches row 40. However, no pop-up shows when I open the file. There are no warning or error signs so I'm not sure what's wrong with it.

Sorry I meant "Sheet3" into "Sheet2"

 

[offthelip]

As I said:

I have written this a stand alone macor for you to check, when you are happy with you can move it to the worksheet open macro:

This macor won't run when you open the workhseet because the top line is comment, to run the macro you need to specifically run the test2 macro. This is so you can test the macro any number of times without needing to open and close the workbook , when you are happy it is working move it to the "this workbook" module ( if it isn't alrady there ) and comment out the line

Sub test2()

and take the single quote out of the line:

'Private Sub Workbook_Open()

 

[dmt32]

Hi,
not tested but see if this update to your existing code will do what you want

Private Sub Workbook_Open()
    
    Dim RegNumberValidUntilCol  As Range, RegNumberValidUntil As Range
    Dim NotificationMsg         As String
    Dim i                       As Long
    Dim ws                      As Worksheet
    
    For Each ws In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet2"))
        
        Set RegNumberValidUntilCol = ws.Range("L2:L19,X2:X19,N2:N19")
        
        For i = 1 To RegNumberValidUntilCol.Areas.Count
            For Each RegNumberValidUntil In RegNumberValidUntilCol.Areas(i)
                
                If IsDate(RegNumberValidUntil) Then
                    If RegNumberValidUntil - Date <= IIf(i < 3, 365, 180) Then
                        NotificationMsg = NotificationMsg & "Sheet: " & ws.Name & " - " & _
                        RegNumberValidUntil.Offset(0, Choose(i, -9, -21, -11)) & Chr(10)
                    End If
                End If
                
            Next RegNumberValidUntil
        Next i
        Set RegNumberValidUntilCol = Nothing
    Next ws
    
    If Len(NotificationMsg) = 0 Then
        
        MsgBox "You Do Not have any product registrations expiring soon.", 64, "Notifications"
        
    Else
        MsgBox "Registrations of the following products are expiring soon: " & NotificationMsg, 48, "Notifications"
        
    End If
    
End Sub

Change sheet names and adjust code to meet specific project need as required

Dave

 

[charlie2503]

Hi,
not tested but see if this update to your existing code will do what you want

Private Sub Workbook_Open()
  
    Dim RegNumberValidUntilCol  As Range, RegNumberValidUntil As Range
    Dim NotificationMsg         As String
    Dim i                       As Long
    Dim ws                      As Worksheet
  
    For Each ws In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet2"))
      
        Set RegNumberValidUntilCol = ws.Range("L2:L19,X2:X19,N2:N19")
      
        For i = 1 To RegNumberValidUntilCol.Areas.Count
            For Each RegNumberValidUntil In RegNumberValidUntilCol.Areas(i)
              
                If IsDate(RegNumberValidUntil) Then
                    If RegNumberValidUntil - Date <= IIf(i < 3, 365, 180) Then
                        NotificationMsg = NotificationMsg & "Sheet: " & ws.Name & " - " & _
                        RegNumberValidUntil.Offset(0, Choose(i, -9, -21, -11)) & Chr(10)
                    End If
                End If
              
            Next RegNumberValidUntil
        Next i
        Set RegNumberValidUntilCol = Nothing
    Next ws
  
    If Len(NotificationMsg) = 0 Then
      
        MsgBox "You Do Not have any product registrations expiring soon.", 64, "Notifications"
      
    Else
        MsgBox "Registrations of the following products are expiring soon: " & NotificationMsg, 48, "Notifications"
      
    End If
  
End Sub

Change sheet names and adjust code to meet specific project need as required

Dave

This totally works! thank you so much for your help!!

If it's not too much of a hassle, I need help to add more detail to the date formula since I'm a bit confused about incorporating it into the code.

So for columns L (RegNumberValidUntil) and X (CertificationValidUntil), I want the reminder to be <=365 days and >=0 days before the "valid until" dates
I've wrote down RegNumberValidUntil - Date <= 365 AND RegNumberValidUntil - Date >=0 (same thing for CertificationValidUntil)

For Column N (Latest Approval), the reminder must be >=180 days and <=365 days after the "last approval" date
Date - LatestApproval >= 180 AND Date - LatestApproval <=365

Are these correct? How do I correctly input them into your code?

 

[dmt32]

This totally works! thank you so much for your help!!

I surprise myself sometimes but glad suggestion helps

done quickly but see if this update does what you want

Private Sub Workbook_Open()
    
    Dim RegNumberValidUntilCol  As Range, RegNumberValidUntil As Range
    Dim NotificationMsg         As String, Prompts As String
    Dim i                       As Long, a As Long, NoDays As Long
    Dim ws                      As Worksheet
    
    Prompts = "You Do Not have any product registrations expiring soon.," & _
              "Registrations of the following products are expiring soon:"
    
    For Each ws In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet2"))
        
        Set RegNumberValidUntilCol = ws.Range("L2:L19,X2:X19,N2:N19")
        
        For i = 1 To RegNumberValidUntilCol.Areas.Count
            For Each RegNumberValidUntil In RegNumberValidUntilCol.Areas(i)
                
                If IsDate(RegNumberValidUntil) Then
                    NoDays = RegNumberValidUntil - Date
                    If NoDays >= IIf(i < 3, 0, 180) And NoDays <= 365 Then
                        If a = 0 Then NotificationMsg = NotificationMsg & Chr(10) & _
                                      ws.Name & Chr(10): a = 1
                        NotificationMsg = NotificationMsg & _
                        RegNumberValidUntil.Offset(0, Choose(i, -9, -21, -11)) & Chr(10)
                    End If
                End If
                
            Next RegNumberValidUntil
        Next i
        Set RegNumberValidUntilCol = Nothing
        a = 0
    Next ws
    
    MsgBox Split(Prompts, ",")(IIf(Len(NotificationMsg) = 0, 0, 1)) & Chr(10) & _
           NotificationMsg, 64, "Notifications"
    
End Sub

I made some other minor changes mainly in how result(s) are displayed


Dave

 

[charlie2503]

I surprise myself sometimes but glad suggestion helps

done quickly but see if this update does what you want

Private Sub Workbook_Open()
   
    Dim RegNumberValidUntilCol  As Range, RegNumberValidUntil As Range
    Dim NotificationMsg         As String, Prompts As String
    Dim i                       As Long, a As Long, NoDays As Long
    Dim ws                      As Worksheet
   
    Prompts = "You Do Not have any product registrations expiring soon.," & _
              "Registrations of the following products are expiring soon:"
   
    For Each ws In ThisWorkbook.Worksheets(Array("Sheet1", "Sheet2"))
       
        Set RegNumberValidUntilCol = ws.Range("L2:L19,X2:X19,N2:N19")
       
        For i = 1 To RegNumberValidUntilCol.Areas.Count
            For Each RegNumberValidUntil In RegNumberValidUntilCol.Areas(i)
               
                If IsDate(RegNumberValidUntil) Then
                    NoDays = RegNumberValidUntil - Date
                    If NoDays >= IIf(i < 3, 0, 180) And NoDays <= 365 Then
                        If a = 0 Then NotificationMsg = NotificationMsg & Chr(10) & _
                                      ws.Name & Chr(10): a = 1
                        NotificationMsg = NotificationMsg & _
                        RegNumberValidUntil.Offset(0, Choose(i, -9, -21, -11)) & Chr(10)
                    End If
                End If
               
            Next RegNumberValidUntil
        Next i
        Set RegNumberValidUntilCol = Nothing
        a = 0
    Next ws
   
    MsgBox Split(Prompts, ",")(IIf(Len(NotificationMsg) = 0, 0, 1)) & Chr(10) & _
           NotificationMsg, 64, "Notifications"
   
End Sub

I made some other minor changes mainly in how result(s) are displayed


Dave

Hi, thanks again for your help!

So columns L (RegNumberValidUntil), and X (CertificationValidUntil) show the right product list in the pop-up. However, it seems like the pop-up does not show the list of products with due dates from column N (Latest Approval) which must be >=180 days and <=365 days after the date listed in column N (Date - LatestApproval >= 180 and <=365). Can you help with this?

 

[dmt32]

Hi, thanks again for your help!

However, it seems like the pop-up does not show the list of products with due dates from column N (Latest Approval) which must be >=180 days and <=365 days after the date listed in column N (Date - LatestApproval >= 180 and <=365). Can you help with this?

try changing this line

 NoDays = RegNumberValidUntil - Date

for this

 NoDays = IIf(i < 3, RegNumberValidUntil - Date, Date - RegNumberValidUntil)

and see if resolves your issue

Dave