Text output based on date criteria

Lrees

New Member
Joined
Feb 7, 2018
Messages
12
Hi everyone,
After many years of diving in and out of the Mr Excel forum for answers to many small questions; it's time to get in and start building up my understanding of macros piece by piece with a figuring some different scenarios these can apply to. Great place, although I've mainly used as reference for formulas and the odd macro for hiding rows and columns to customize various views.

I'm looking to put together a macro that will fill a cell along rows of a table based on certain criteria. I've used this to track actions from meetings however cell E3 had a lengthy formula and didn't cover everything I want to get achieve (along with being difficult to easily alter).

This is intended to run through the length of a table. Apologies if the below gets a little confusing. Dates are DD/MM/YY.

Cell A1 has date of previous meeting ie 01/05/18

Cell A3 has activity description
Cell B3 has date raised ie "04/05/2018"
Cell C3 has date due or note ie "10/05/18" or "Note"
Cell D3 has date complete ie "09/05/18"
Cell E3 has status (this is the cell I want to auto-fill)

1. If Cell B1 is not blank, but cell C3 is blank, cell E3 returns "No Due Date"
2. If Cell D3 is not blank (ie has a completed date) then cell E3 changes to "Complete", or "Closed" if cell D3 is prior to cell A1 - 7 days
3. If Cell C3 says "Note" then, E3 returns "Note" or "Old Note" if B3 is prior to cell A1
4. If Cell C3 date equals todays date then cell E3 returns "Due Today"
5. If Cell C3 date is within 7 days of todays date cell E3 Returns "Due Within 7 Days"
6. If Cell C3 dats is between 7-14 days of todays date cell E3 returns "Due Within 14 Days"
7. If Cell C3 date is greater than 14 days from todays date cell E3 returns "Open"
8. If Cell C3 date less than todays date then cell E3 returns "Overdue"

This would need to run to the end of the table - note sure how you would define that.
End goal would be to color each row in column C of the table based on the outcome ie "overdue" red, "due today" orange etc.

Previous Meeting:1/05/2018(Assume todays date is 18/05/18)
ItemRaisedDueCompleteStatus
Task 14/05/2018No Due Date
Task 2.14/05/20187/05/20188/05/2018Complete
Task 2.21/04/20188/04/20189/04/2018Closed
Task 34/05/2018NoteNote
Task 44/05/201818/05/2018Due Today
Task 54/05/201820/05/2018Due Within 7 Days
Task 64/05/201828/05/2018Due Within 14 Days
Task 74/05/20182/06/2018Open
Task 84/05/201815/05/2018Overdue

<tbody>
</tbody><colgroup><col><col span="3"><col></colgroup>
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!

frank_AL

Active Member
Joined
Oct 30, 2015
Messages
444
Lrees,

First let me say THANK YOU for very descriptive post! I think I can build you a solution and it is so helpful to have sample data and definitive requirements. So often that is not the case!

I'll get back to you with a solution.
 

Lrees

New Member
Joined
Feb 7, 2018
Messages
12
Lrees,

First let me say THANK YOU for very descriptive post! I think I can build you a solution and it is so helpful to have sample data and definitive requirements. So often that is not the case!

I'll get back to you with a solution.

Thanks Frank_AL, thought it's best to give some background info on it's end use to other can maybe use or adapt to suit another method.
 

frank_AL

Active Member
Joined
Oct 30, 2015
Messages
444
Okay, I think I have a solution for you. Give it a try and let me know if you encounter any problems.

Code:
Option Explicit


Sub CalculateStatus()
Dim lr As Long
Dim i As Long


lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To lr
    If Cells(i, "C") = "" Then
        Cells(i, "E").Value = "No Due Date"
    ElseIf Cells(i, "D").Value <> "" Then
        If Cells(i, "D").Value - Cells(1, "A").Value >= 7 Then
            Cells(i, "E").Value = "Complete"
        Else
            Cells(i, "E").Value = "Closed"
        End If
    ElseIf Cells(i, "C").Value <> "" Then
        If Cells(i, "C").Value = "Note" Then
            If Cells(i, "B").Value < Cells(1, "A").Value Then
                Cells(i, "E").Value = "Old Note"
            Else
                Cells(i, "E").Value = "Note"
            End If
'        If Cells(i, "C").Value = Date Then
        ElseIf Cells(i, "C").Value - Cells(1, "A") >= 0 Then
            If Cells(i, "C").Value = Cells(1, "C").Value Then
                Cells(i, "E").Value = "Due Today"
            ElseIf Cells(i, "C").Value - Cells(1, "A") <= 7 Then
                Cells(i, "E").Value = "Due Within 7 Days"
            ElseIf Cells(i, "C").Value - Cells(1, "A") <= 14 Then
                Cells(i, "E").Value = "Due Within 14 Days"
            ElseIf Cells(i, "C").Value - Cells(1, "A") > 14 Then
                Cells(i, "E").Value = "Open"
            End If
        ElseIf Cells(i, "C").Value - Cells(1, "A") < 0 Then
                Cells(i, "E").Value = "Overdue"
        End If
    End If
Next i
    
        
    
    


End Sub
 

frank_AL

Active Member
Joined
Oct 30, 2015
Messages
444
Modified code to address date value equal toToday

Code:
Option Explicit


Sub CalculateStatus()
Dim lr As Long
Dim i As Long


lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To lr
    If Cells(i, "C") = "" Then
        Cells(i, "E").Value = "No Due Date"
    ElseIf Cells(i, "D").Value <> "" Then
        If Cells(i, "D").Value - Cells(1, "A").Value >= 7 Then
            Cells(i, "E").Value = "Complete"
        Else
            Cells(i, "E").Value = "Closed"
        End If
    ElseIf Cells(i, "C").Value <> "" Then
        If Cells(i, "C").Value = "Note" Then
            If Cells(i, "B").Value < Cells(1, "A").Value Then
                Cells(i, "E").Value = "Old Note"
            Else
                Cells(i, "E").Value = "Note"
            End If
        ElseIf Cells(i, "C").Value - Cells(1, "A") >= 0 Then
            If Cells(i, "C").Value = Date Then
                Cells(i, "E").Value = "Due Today"
            ElseIf Cells(i, "C").Value - Cells(1, "A") <= 7 Then
                Cells(i, "E").Value = "Due Within 7 Days"
            ElseIf Cells(i, "C").Value - Cells(1, "A") <= 14 Then
                Cells(i, "E").Value = "Due Within 14 Days"
            ElseIf Cells(i, "C").Value - Cells(1, "A") > 14 Then
                Cells(i, "E").Value = "Open"
            End If
        ElseIf Cells(i, "C").Value - Cells(1, "A") < 0 Then
                Cells(i, "E").Value = "Overdue"
        End If
    End If
Next i
 

Lrees

New Member
Joined
Feb 7, 2018
Messages
12
Thanks Frank_AL, worked a treat!

Modified code to address date value equal toToday

Code:
Option Explicit


Sub CalculateStatus()
Dim lr As Long
Dim i As Long


lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 3 To lr
    If Cells(i, "C") = "" Then
        Cells(i, "E").Value = "No Due Date"
    ElseIf Cells(i, "D").Value <> "" Then
        If Cells(i, "D").Value - Cells(1, "A").Value >= 7 Then
            Cells(i, "E").Value = "Complete"
        Else
            Cells(i, "E").Value = "Closed"
        End If
    ElseIf Cells(i, "C").Value <> "" Then
        If Cells(i, "C").Value = "Note" Then
            If Cells(i, "B").Value < Cells(1, "A").Value Then
                Cells(i, "E").Value = "Old Note"
            Else
                Cells(i, "E").Value = "Note"
            End If
        ElseIf Cells(i, "C").Value - Cells(1, "A") >= 0 Then
            If Cells(i, "C").Value = Date Then
                Cells(i, "E").Value = "Due Today"
            ElseIf Cells(i, "C").Value - Cells(1, "A") <= 7 Then
                Cells(i, "E").Value = "Due Within 7 Days"
            ElseIf Cells(i, "C").Value - Cells(1, "A") <= 14 Then
                Cells(i, "E").Value = "Due Within 14 Days"
            ElseIf Cells(i, "C").Value - Cells(1, "A") > 14 Then
                Cells(i, "E").Value = "Open"
            End If
        ElseIf Cells(i, "C").Value - Cells(1, "A") < 0 Then
                Cells(i, "E").Value = "Overdue"
        End If
    End If
Next i
 

Forum statistics

Threads
1,147,498
Messages
5,741,503
Members
423,663
Latest member
kaveh87rsh

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
Top