VBA popup box warning of expiration date

[Watchdawg]

Hello guru's! I'm trying to get a popup window to show when a date is entered that is less than 8 months from today's date.
I also need it to send out the alert when the spreadsheet is opened.
Basically, Column A is the part number, Column B is the lot number and Column C is the expiration date. If the user enters a date into column C (which is currently 57 lines long, but could be as many as 200) and it's less than 8 months out, it displays "Part A, Lot B is within the 8 month requirement". They should be able to close the window out in case it's going to be accepted anyway. Therefor, once the workbook is opened again, it needs to check for expiration dates that are already populated for the same criteria and display a list of parts/lots that are out of tolerance.
And just because I can't make it simple, if the expiration date doesn't have anything entered, it shouldn't throw out the warning, just move on to the next populated cell.

 

[My Aswer Is This]

Well then this proves you know how to install the script.

The previous script I sent you should popup a MsgBox if you enter this date in column C
8/8/2018

What country do you live in?
Some countries handle dates differently.



This script:

Private Sub Worksheet_Change(ByVal Target As Range)
'Modified 6/19/18 10:00 PM EDT
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    If Target.Value < DateAdd("M", "8", Date) Then
        ans = "Part Number " & Target.Offset(, -2).Value
        anss = "Lot Number " & Target.Offset(, -1).Value
        MsgBox ans & vbNewLine & anss & vbNewLine & "Is within the 8 month requirement"
    End If
End If
End Sub

 

[My Aswer Is This]

Tell me what happens when you run this script:
Is the date displayed in the message box Todays Date?

Private Sub Worksheet_Change(ByVal Target As Range)
'Modified 6/19/18 10:00 PM EDT
If Not Intersect(Target, Range("C:C")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
    
    MsgBox "Today is   " & Date
    
End If
End Sub

You must enter something in column C

 

[Watchdawg]

I'm in the United States

 

[Watchdawg]

Yep, today's date

 

[My Aswer Is This]

I do not know what to say.
If you entered the date:
8/8/2018 in column C and nothing happened then I'm not sure what to say.

When I do that the script runs. You should get a popup message.

And I'm sure you must be entering 8/8/2018

And not something like:

My birthday is 8/8/2018

 

[Watchdawg]

Did you hear that? It was my head banging against the desk. Sometimes it's the simplest things that screw everything up! I changed the format in the cell to date from text. **POOF** works like a charm! Thanks!

 

[My Aswer Is This]

So that solved question 1

Now you want a script to run when you open the workbook.

So when you open the workbook you want a list of all the dates in column 3 that meet the criteria listed where?

Like I need you to say:

Show the list in sheet named "Me"

And enter only the values in columns A B and C
Or copy the whole row to the other sheet. If the criteria is met.

 

[Watchdawg]

Actually we can scratch that idea. I'm not going to distribute the file out to the other user, they'll receive a cut/paste of specific items, so the only person that needs to see the message is the one entering the data Again. Thank you so much for working this out for me.

 

[My Aswer Is This]

Well I already wrote a script to do this.
You can look at how it works.
Put this script in a button or run it how you want.
It does not run when you open the workbook
Run this script from the sheet where you have your data.

This script will copy rows to Sheet(2)

Sub Test()
'Modified 6/20/2018 11:45 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1
Lastrow = Cells(Rows.Count, "C").End(xlUp).Row
For i = 1 To Lastrow
    If Cells(i, 3).Value < DateAdd("M", "8", Date) Then
        Rows(i).Copy Sheets(2).Rows(Lastrowa)
        Lastrowa = Lastrowa + 1
    End If
Next
Application.ScreenUpdating = True
End Sub