VBA code to create message box pop up for expiry dates in multiple sheets

Dee05

New Member
Joined
Aug 14, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Hi everyone! This is my first time here so I am not sure what to expect but would be very grateful to anyone who takes the time to help me. I am also currently teaching myself the ins and outs of excel/VBA. I understand some things but have a lot to learn.

I have a workbook with 9 sheets. Sheets 1 - 8 are for different labs and lists expiry dates for the consumables in each lab, sheet names are Lab 1, Lab 2 etc. Sheet 9, named Dropdown data, contains only dropdown list data.
What I am trying to do is create a message notification that pops up when the workbook is opened (no matter what sheet is selected). I would like this notification to have a message box name of “Expiring consumables” then show a message “The following consumables are expired or about to expire. Please action.” And then list all the consumables on each spreadsheet that are about to expire within 30 days.
e.g
The following consumables are expired or about to expire. Please action.

Lab 1: Swabs expiring in x days
Lab 2: Sterile water expiring in x days

Then show nothing for any labs with no consumables expiring. I do not want the dropdown sheet included ever.
My consumables are in column B, my expiry dates in column C. The row range is 6 - 1000. This is the case for all 8 lab sheets. The sheets contain previously expired consumables also but I don’t want all of these to pop up. Perhaps only those that have expired in the past 5 days.

I have tried and failed many, many times to work this out. I have this code which gives me the right notification (no message box name though) but only for the one Sheet and shows no expired items.

Sub popup()
Dim lstrow As Long
Dim i As Long
Dim msg As String
msg = “The following consumables are expired or about to expire. Please action.” & vbCrLf & vbCrLf
lstrow = Range(“C” & Rows.Count).End(xlUp).Row
For i = 6 To lstrow
If Range(“C” & i) - Date <= 30 And Range(“C” & i) - Date > 0 Then
msg = msg & Sheet.4Name & “: “ & Range(“B” & i).Value & “expires in “ & Range(“C” & i) - Date & “ Days” & vbCrLf & vbCrLf
End If
Next i
Msgbox msg
End Sub

I hope it have provided enough context. Thank you very much to anyone who can lend a hand. I am in awe of all of you Excel experts!
 

Some videos you may like

Excel Facts

Links? Where??
If Excel says you have links but you can't find them, go to Formulas, Name Manager. Look for old links to dead workbooks & delete.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,523
Office Version
  1. 2013
Platform
  1. Windows
See if this is something like you want.

VBA Code:
Sub t()
Dim i As Long, c As Range, exp As String, msg As String
    For i = 1 To 8
        With Sheets(i)
            For Each c In .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
                If c.Value < (Date + 30) Then
                    exp = exp & "Lab " & i & ": " & c.Offset(, -1).Value & " - " & c.Value & vbLf
                End If
            Next            
        End With
    Next
    MsgBox exp
End Sub
 
Last edited:

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,523
Office Version
  1. 2013
Platform
  1. Windows
This should actually be in your ThisWorkbook code module as a Workbook_Open macro to make it work when you open the workbook.

VBA Code:
Private Sub Workbook_Open()
Dim i As Long, c As Range, exp As String
    For i = 1 To 8
        With Sheets(i)
            For Each c In .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
                If c.Value < (Date + 30) Then
                    exp = exp & "Lab " & i & ": " & c.Offset(, -1).Value & " - " & c.Value & vbLf
                End If
            Next
        End With
    Next
    MsgBox exp
End Sub
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,523
Office Version
  1. 2013
Platform
  1. Windows
Use this instead, it eliminates the extraneous listing of blank cells.

VBA Code:
Private Sub Workbook_Open()
Dim i As Long, c As Range, exp As String, msg As String
    For i = 1 To 8
        With Sheets(i)
            For Each c In .Range("C2", .Cells(Rows.Count, 3).End(xlUp))
                If c <> "" Then
                    If c.Value < (Date + 30) Then
                        exp = exp & "Lab " & i & ": " & c.Offset(, -1).Value & " - " & c.Value & vbLf
                    End If
                End If
            Next
        End With
    Next
    MsgBox exp
End Sub
 

Dee05

New Member
Joined
Aug 14, 2020
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Use this instead, it eliminates the extraneous listing of blank cells...

Hello JLGWhiz!
You’re my hero! I cannot thank you enough for taking the time to assist me, and so quickly too. Your code worked perfectly.
I just tweaked it to add in the message “The following items...” and excluded all expired consumables all except those that expired within the last 5 days.
It’s working so well, I am very happy.
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,523
Office Version
  1. 2013
Platform
  1. Windows
Hello JLGWhiz!
You’re my hero! I cannot thank you enough for taking the time to assist me, and so quickly too. Your code worked perfectly.
You're welcome,
regards, JLG
 

Watch MrExcel Video

Forum statistics

Threads
1,114,139
Messages
5,546,179
Members
410,731
Latest member
keobongmacao
Top