VBA Expiry date with entire row Color highlight & new column with status

[mohanprabhus]

I'm trying to write a VBA CODE example mentioned below. Help on the below-mentioned example

A	B	C	D
SL NO	PRODUCT	MANUFACTURING DATE	EXPIRY DATE
1	ABC	01-01-2021	01-01-2022
2	XYZ	29-03-2021	29-03-2022
3	CDA	04-05-2019	04-05-2020
4	TWC	23-03-2021	23-03-2021

I want my output as mentioned below

A	B	C	D	E	F
SL NO	PRODUCT	MANUFACTURING DATE	EXPIRY DATE	CURRENT DATE	STATUS
1	ABC	01-01-2021	01-01-2022	23-03-2022	OVERDUE in 81 Days
2	XYZ	29-03-2021	29-03-2022	23-03-2022	Going to Expire in Next 6 Days
3	CDA	04-05-2019	04-05-2020	23-03-2022	OVERDUE in 688 Days
4	TWC	23-03-2021	23-03-2021	23-03-2022	Expiring today
5	JSJD	20-03-2021	20-03-2022	23-03-2022	Expired in 3 days
6	DDFDFA	24-03-2021	24-03-2022	23-03-2022	Expirining Tomorrow

Conditions
Overdue means more than 15 days from Current Date
Expired Today Current Date and Expiry Date
Expiring Tomorrow Current Date and Expiry Date
Going to Expiry Current date within 15 days

Advance in Thanks.

 

[gordsky]

the below may do what you want.
I have made an assumption that your DATA in cell D4 is incorrect as you have shown the result to be Expiring today but there is actually a year difference between the dates so should be expired 365 based on your conditions of current date - expiry date

Dim ws As Worksheet
Dim Myday As Long
Dim cel As Range, MyRng As Range

Set ws = ActiveSheet
Set MyRng = ws.Range("D2:D" & ws.Cells(Rows.count, 4).End(xlUp).row)

For Each cel In MyRng
   ws.Cells(cel.row, 5) = Date
   Myday = ws.Cells(cel.row, 5) - ws.Cells(cel.row, 4)
   Select Case Myday
      Case 0: ws.Cells(cel.row, 6) = "Expiring Today"
      Case 1: ws.Cells(cel.row, 6) = "Expiring Tomorrow"
      Case 2 To 15: ws.Cells(cel.row, 6) = "Expires in " & Myday & " Days"
      Case Else: ws.Cells(cel.row, 6) = "Overdue in " & Myday & " Days"
   End Select
Next cel

 

[mohanprabhus]

the below may do what you want.
I have made an assumption that your DATA in cell D4 is incorrect as you have shown the result to be Expiring today but there is actually a year difference between the dates so should be expired 365 based on your conditions of current date - expiry date

Dim ws As Worksheet
Dim Myday As Long
Dim cel As Range, MyRng As Range

Set ws = ActiveSheet
Set MyRng = ws.Range("D2:D" & ws.Cells(Rows.count, 4).End(xlUp).row)

For Each cel In MyRng
   ws.Cells(cel.row, 5) = Date
   Myday = ws.Cells(cel.row, 5) - ws.Cells(cel.row, 4)
   Select Case Myday
      Case 0: ws.Cells(cel.row, 6) = "Expiring Today"
      Case 1: ws.Cells(cel.row, 6) = "Expiring Tomorrow"
      Case 2 To 15: ws.Cells(cel.row, 6) = "Expires in " & Myday & " Days"
      Case Else: ws.Cells(cel.row, 6) = "Overdue in " & Myday & " Days"
   End Select
Next cel

Thank you gordsky, But Expiring Tomorrow Does not work. And also request you to help the complete row to highlight with RED for OverDue, Expires within 15 days with Grey Color, Expiring Today with Blue Color & Expiring tomorrow, or within the next 15 days with green color.

Advance in Thanks.

 

[gordsky]

Thank you gordsky, But Expiring Tomorrow Does not work. And also request you to help the complete row to highlight with RED for OverDue, Expires within 15 days with Grey Color, Expiring Today with Blue Color & Expiring tomorrow, or within the next 15 days with green color.

Advance in Thanks.

you should really be more specific than "Doesnt work" however i think if you change the

 Myday = ws.Cells(cel.row, 5) - ws.Cells(cel.row, 4)

to

Myday = Abs(ws.Cells(cel.row, 5) - ws.Cells(cel.row, 4))

then it will work.

As you made no request for colours in your origional post one was not included. You would prob be better doing that through conditional formatting on the sheet

 

[mohanprabhus]

you should really be more specific than "Doesnt work" however i think if you change the

 Myday = ws.Cells(cel.row, 5) - ws.Cells(cel.row, 4)

to

Myday = Abs(ws.Cells(cel.row, 5) - ws.Cells(cel.row, 4))

then it will work.

As you made no request for colours in your origional post one was not included. You would prob be better doing that through conditional formatting on the sheet

Thank you gordsky, It was much helpful & definitely i will do conditional formatting, But I do face one more problem here For example my Expiry is not past may be future dates like or 23-06-2022, 23-05-2023 then the output says overdue, actual it is not yet due. The message should Valid instead of overdue.

Advance in Thanks.

 

[gordsky]

Thank you gordsky, It was much helpful & definitely i will do conditional formatting, But I do face one more problem here For example my Expiry is not past may be future dates like or 23-06-2022, 23-05-2023 then the output says overdue, actual it is not yet due. The message should Valid instead of overdue.

Advance in Thanks.

It would be more helpful if you supplied all the info in one go. Again your origional post did not mention future dates only the 4 criteria the code was written for.

new code is

Sub test()
Dim ws As Worksheet
Dim Myday As Long
Dim cel As Range, MyRng As Range

Set ws = ActiveSheet
Set MyRng = ws.Range("D2:D" & ws.Cells(Rows.count, 4).End(xlUp).row)

For Each cel In MyRng
   ws.Cells(cel.row, 5) = Date
   
   Myday = ws.Cells(cel.row, 4) - ws.Cells(cel.row, 5)
   Select Case Myday
      Case 0: ws.Cells(cel.row, 6) = "Expiring Today"
      Case 1: ws.Cells(cel.row, 6) = "Expiring Tomorrow"
      Case 2 To 15: ws.Cells(cel.row, 6) = "Expires in " & Myday & " Days"
      Case Is > 15: ws.Cells(cel.row, 6) = "Valid"
      Case Else: ws.Cells(cel.row, 6) = "Overdue by " & Myday * -1 & " Days"
   End Select
Next cel

End Sub

 

[gordsky]

It would be more helpful if you supplied all the info in one go. Again your origional post did not mention future dates only the 4 criteria the code was written for.

new code is

Sub test()
Dim ws As Worksheet
Dim Myday As Long
Dim cel As Range, MyRng As Range

Set ws = ActiveSheet
Set MyRng = ws.Range("D2:D" & ws.Cells(Rows.count, 4).End(xlUp).row)

For Each cel In MyRng
   ws.Cells(cel.row, 5) = Date
   
   Myday = ws.Cells(cel.row, 4) - ws.Cells(cel.row, 5)
   Select Case Myday
      Case 0: ws.Cells(cel.row, 6) = "Expiring Today"
      Case 1: ws.Cells(cel.row, 6) = "Expiring Tomorrow"
      Case 2 To 15: ws.Cells(cel.row, 6) = "Expires in " & Myday & " Days"
      Case Is > 15: ws.Cells(cel.row, 6) = "Valid"
      Case Else: ws.Cells(cel.row, 6) = "Overdue by " & Myday * -1 & " Days"
   End Select
Next cel

End Sub

Did this solve your query