How to use traffic light conditional formatting icon set with dates.

I couldnt find this anywhere by searching it, so I figured it out and thought I would share the results.

I wanted to have a traffic light change color depending how close the current date was to a date in a particular cell in the spreadsheet. Green for more than 14 days away, yellow for less than 14 days away, and red for today or past due.

This would be useful for upcoming tasks/calander organizing etc.

I made it extremely easy to modify/edit for your own purposes, there are two parts. One part will update the entire spreadsheet, you could assing it to the button, the other part will make it so that any new changes to dates put into the spreadsheet will have it automatically update the corresponding traffic light.

The macro part you would add as a module:

Sub FullUpdate()
   
        Dim StringDate As String
        'Column number with the date in it (column a = 1, column b = 2, column c = 3, etc)
        ColumnWithDate = 6
        'Column number with the conditional formatting for the traffic lights in it
        ColumnForResults = 7
        StringDate = Date
        GreenDate = DateAdd("d", 14, StringDate)
        'What row to start the update on (skip your header/title row)
        BeginRow = 2
        'What row to end the update on (the more you update the longer it will take to run)
        EndRow = 32

 For RowCnt = BeginRow To EndRow
 
    If ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) = "" Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = ""
    End If
    
    If ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) <= StringDate Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = "1"
    End If
    
    If (ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) > StringDate) And (ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) < GreenDate) Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = "2"
    End If
    
    If (ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) >= GreenDate) Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = "3"
    End If
    
Next RowCnt

End Sub

and here is the party you would put on the sheet code:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    ' If any cell in this range is changed, it will update the # for the traffic light
    '   conditional formatting in the cell directly to the right of it
    Set KeyCells = Range("F2:F300")
    'Set this number to how many days before the current date for the light to be yellow
    DaysForYellow = 14
    
    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
        Is Nothing Then
           
        StringDate = Date
        GreenDate = DateAdd("d", DaysForYellow, StringDate)
 
    
    If Target.Address <= StringDate Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(Target.Row, Target.Column + 1) = "1"
    End If
    
    
    If (Target.Address > StringDate) And (Target.Address < GreenDate) Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(Target.Row, Target.Column + 1) = "2"
    End If
    
     
    If Target.Address >= GreenDate Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(Target.Row, Target.Column + 1) = "3"
    End If
    
   
    If Target.Address = "" Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(Target.Row, Target.Column + 1) = ""
    End If
       
    End If
End Sub

You would need to format the column directly to the right of your dates (in this example, column 7) for conditional formatting with traffic light icon set, where green is >= 3, yellow is 2, and red is 1 and have it hide the data.

If you have any questions about this, let me know I'd be happy to explain further.

Ok so I have a problem with this code. It works 100% fine on Excel 2007. When I try to use it in Excel 2013, it seems when it is comparing the date, it is messing up and always is showing the wrong value, any ideas on why this would be?

Heres the fix when updating to 2013

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim KeyCells As Range
    Set KeyCells = Range("F2:F300")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
        Is Nothing Then

Dim StringDate As String
        'Column number with the date in it (column a = 1, column b = 2, column c = 3, etc)
        ColumnWithDate = 6
        'Column number with the conditional formatting for the traffic lights in it
        ColumnForResults = 7
        StringDate = Date
        GreenDate = DateAdd("d", 14, StringDate)
        'What row to start the update on (skip your header/title row)
        BeginRow = 2
        'What row to end the update on (the more you update the longer it will take to run)
        EndRow = 32

 
   
    
    If ActiveSheet.Cells(Target.Row, Target.Column).Value <= StringDate Then
        ActiveSheet.Cells(Target.Row, Target.Column + 1) = "1"
    End If
    
    If ActiveSheet.Cells(Target.Row, Target.Column).Value > StringDate And ActiveSheet.Cells(Target.Row, Target.Column).Value < GreenDate Then
        ActiveSheet.Cells(Target.Row, Target.Column + 1) = "2"
    End If
    
    If ActiveSheet.Cells(Target.Row, Target.Column).Value >= GreenDate Then
        ActiveSheet.Cells(Target.Row, Target.Column + 1) = "3"
    End If
    
If ActiveSheet.Cells(Target.Row, Target.Column).Value = "" Then
        ActiveSheet.Cells(Target.Row, Target.Column + 1) = ""
    End If

End If

End Sub

Sub FullUpdate()
   
        Dim StringDate As String
        'Column number with the date in it (column a = 1, column b = 2, column c = 3, etc)
        ColumnWithDate = 6
        'Column number with the conditional formatting for the traffic lights in it
        ColumnForResults = 7
        StringDate = Date
        GreenDate = DateAdd("d", 14, StringDate)
        'What row to start the update on (skip your header/title row)
        BeginRow = 2
        'What row to end the update on (the more you update the longer it will take to run)
        EndRow = 32

 For RowCnt = BeginRow To EndRow
   
    If ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) <= StringDate Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = "1"
    End If
    
    If (ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) > StringDate) And (ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) < GreenDate) Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = "2"
    End If
    
    If (ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) >= GreenDate) Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = "3"
    End If
    
    If ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnWithDate) = "" Then
        ActiveWorkbook.Worksheets("Sheet1").Cells(RowCnt, ColumnForResults) = ""
    End If

Next RowCnt

End Sub