VBA code for expiring dates (3 variables)

gigiUSA

New Member
Joined
Oct 1, 2021
Messages
8
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
Hello,

I apologize if there is a post about this, but I haven't been able to find a fix for my particular situation. I am working on a spreadsheet that can track some reagents and alert at opening with message boxes about 3 options: 1) No expired reagents, 2) Reagents about to expire within the next 30 days (Msgbox should display what reagent is about to expire), 3) Expired reagents (Msgbox should display what reagents have expired).

Relevant columns are A (Reagent name) and D (Expiration date).

This is the code I have so far. Unfortunately it only shows expired reagents and no expired reagents. I don't know how to add the third option for about to expire in 30 days and make it work. Many Thanks!!!!!

Private Sub Workbook_Open()

Dim ExpirationDateCol As Range
Dim ExpirationDate As Range
Dim NotificationMsg As String

Set ExpirationDateCol = Range("D2:D10000")

For Each ExpirationDate In ExpirationDateCol

If ExpirationDate <> "" And Date >= ExpirationDate Then
NotificationMsg = NotificationMsg & " " & ExpirationDate.Offset(0, -3)
End If

Next ExpirationDate

If NotificationMsg = "" Then

MsgBox "There are no expired reagents."

Else: MsgBox "The followinging reagents have EXPIRED (Remove from circulation): " & NotificationMsg

End If


End Sub
 

Excel Facts

Test for Multiple Conditions in IF?
Use AND(test, test, test, test) or OR(test, test, test, ...) as the logical_test argument of IF.
How about:
VBA Code:
Private Sub Workbook_Open()
Dim ExpirationDateCol As Range
Dim ExpirationDate As Range
Dim NotificationMsg As String
Dim NotificationMsg2 As String

Set ExpirationDateCol = Range("D2:D10000")

For Each ExpirationDate In ExpirationDateCol

If ExpirationDate <> "" Then

Select Case Date - ExpirationDate
    
    Case Is > 30
        NotificationMsg = NotificationMsg & " " & ExpirationDate.Offset(0, -3)
    Case Is >= 0
        NotificationMsg2 = NotificationMsg2 & " " & ExpirationDate.Offset(0, -3)
        NotificationMsg = NotificationMsg & " " & ExpirationDate.Offset(0, -3)
        
End Select

End If
Next ExpirationDate

If NotificationMsg = "" Then

MsgBox "There are no expired reagents."

Else
MsgBox "The followinging reagents have EXPIRED (Remove from circulation): " & vbLf & NotificationMsg
If NotificationMsg2 <> "" Then MsgBox "The followinging reagents Will EXPIRED at less than 30 Days(Remove from circulation): " & vbLf & NotificationMsg2
End If

End Sub
 
Upvote 0
My submission would look like ...
VBA Code:
Private Sub Workbook_Open()

    Dim ExpirationDateCol As Range
    Dim ExpirationDate As Range
    Dim ExpiredMsg As String
    Dim ThirtyMsg As String
    
    With ActiveSheet
        Set ExpirationDateCol = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With

    For Each ExpirationDate In ExpirationDateCol
        If ExpirationDate <> "" Then
            If Date >= ExpirationDate Then
                ExpiredMsg = ExpiredMsg & ExpirationDate.Offset(0, -3) & vbNewLine
            ElseIf Date >= ExpirationDate - 30 Then
                ThirtyMsg = ThirtyMsg & ExpirationDate.Offset(0, -3).Value & " (" & ExpirationDate.Value & ")" & vbNewLine
            End If
        End If
    Next ExpirationDate

    If ExpiredMsg = "" Then
        MsgBox "There are no expired reagents."
    Else
        MsgBox "The followinging reagents have EXPIRED (Remove from circulation):" & vbNewLine & ExpiredMsg
    End If
    If ThirtyMsg = "" Then
        MsgBox "There are no reagents about to expire within 30 days"
    Else
        MsgBox "The followinging reagents are about to expire within 30 days:" & vbNewLine & ThirtyMsg
    End If
End Sub
 
Upvote 0
Solution
My submission would look like ...
VBA Code:
Private Sub Workbook_Open()

    Dim ExpirationDateCol As Range
    Dim ExpirationDate As Range
    Dim ExpiredMsg As String
    Dim ThirtyMsg As String
   
    With ActiveSheet
        Set ExpirationDateCol = .Range("D2:D" & .Cells(.Rows.Count, "D").End(xlUp).Row)
    End With

    For Each ExpirationDate In ExpirationDateCol
        If ExpirationDate <> "" Then
            If Date >= ExpirationDate Then
                ExpiredMsg = ExpiredMsg & ExpirationDate.Offset(0, -3) & vbNewLine
            ElseIf Date >= ExpirationDate - 30 Then
                ThirtyMsg = ThirtyMsg & ExpirationDate.Offset(0, -3).Value & " (" & ExpirationDate.Value & ")" & vbNewLine
            End If
        End If
    Next ExpirationDate

    If ExpiredMsg = "" Then
        MsgBox "There are no expired reagents."
    Else
        MsgBox "The followinging reagents have EXPIRED (Remove from circulation):" & vbNewLine & ExpiredMsg
    End If
    If ThirtyMsg = "" Then
        MsgBox "There are no reagents about to expire within 30 days"
    Else
        MsgBox "The followinging reagents are about to expire within 30 days:" & vbNewLine & ThirtyMsg
    End If
End Sub

Thank you very much!!!!!!!! Works exactly as I was wanting and better!! You added the dates to the reagents that are about to expire.
 
Upvote 0
How about:
VBA Code:
Private Sub Workbook_Open()
Dim ExpirationDateCol As Range
Dim ExpirationDate As Range
Dim NotificationMsg As String
Dim NotificationMsg2 As String

Set ExpirationDateCol = Range("D2:D10000")

For Each ExpirationDate In ExpirationDateCol

If ExpirationDate <> "" Then

Select Case Date - ExpirationDate
   
    Case Is > 30
        NotificationMsg = NotificationMsg & " " & ExpirationDate.Offset(0, -3)
    Case Is >= 0
        NotificationMsg2 = NotificationMsg2 & " " & ExpirationDate.Offset(0, -3)
        NotificationMsg = NotificationMsg & " " & ExpirationDate.Offset(0, -3)
       
End Select

End If
Next ExpirationDate

If NotificationMsg = "" Then

MsgBox "There are no expired reagents."

Else
MsgBox "The followinging reagents have EXPIRED (Remove from circulation): " & vbLf & NotificationMsg
If NotificationMsg2 <> "" Then MsgBox "The followinging reagents Will EXPIRED at less than 30 Days(Remove from circulation): " & vbLf & NotificationMsg2
End If

End Sub
Many thanks for your response!!!
 
Upvote 0
Glad to help & thanks for letting us know.
Welcome to MrExcel!
 
Upvote 0
Really thanks all!! I have been trying to deal with this by myself (and Google) for about 2 days.....you guys solved it in less than an hour! I'm glad I joined MrExcel!!
 
Upvote 0

Forum statistics

Threads
1,213,495
Messages
6,113,992
Members
448,538
Latest member
alex78

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top