I have an Excel 07 spreadsheet that is A1:M2, setup as a table (Row 1 headers). The spreadsheet will grow as data is added. I have the following code that I have found on the message board. Column A has a formula that will display the cases indicated in the code below. The formula is working correctly to display the text; however, the cell color code is not working. The calendar code is working correctly. No error message, just not coloring the cells.
Code:
Option Compare Text 'A=a, B=b, ... Z=z
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0
If Rng1 Is Nothing Then
Set Rng1 = Range(Target.Address)
Else
Set Rng1 = Union(Range(Target.Address), Rng1)
End If
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = xlNone
Cell.Font.Bold = False
Case "ACTIVE"
Cell.Interior.ColorIndex = 4
Cell.Font.ColorIndex = 2
Cell.Font.Bold = True
Case "EXPIRED"
Cell.Interior.ColorIndex = 1
Cell.Font.ColorIndex = 2
Cell.Font.Bold = True
Case "SESSION 1 PAST DUE", "SESSION 2 PAST DUE", "SESSION 3 PAST DUE", "SESSION 4 PAST DUE"
Cell.Interior.ColorIndex = 3
Cell.Font.ColorIndex = 2
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next
End Sub
Private Sub Calendar1_Click()
ActiveCell.Value = CDbl(Calendar1.Value)
ActiveCell.NumberFormat = "mm/dd/yyyy"
ActiveCell.Select
Calendar1.Visible = False
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Application.Intersect(Range("F2:F200,J2:J200,K2:K200,L2:L200,M2:M200"), Target) Is Nothing Then
Calendar1.Left = Target.Left + Target.Width - Calendar1.Width
Calendar1.Top = Target.Top + Target.Height
Calendar1.Visible = True
' select Today's date in the Calendar
Calendar1.Value = Date
ElseIf Calendar1.Visible Then Calendar1.Visible = False
End If
End Sub
