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.
Bookmarks