This version also seems to work and is more self-documentary IMO
Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "B2:B20"
Dim currDate As Date
Dim sFormula As String
On Error GoTo ws_exit
Application.EnableEvents = False
If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
On Error Resume Next
currDate = .Value
If Err.Number <> 0 Then
.Value = DateSerial(Left$(.Value2, 4), Mid$(.Value2, 5, 2),
Right$(.Value2, 2))
End If
On Error GoTo ws_exit
.NumberFormat = "yyyymmdd"
.FormatConditions.Delete
sFormula = "=AND(" & .Address(False, False) & _
">=TODAY()<,>" & .Address(False, False) & _
"<=DATE(YEAR(TODAY())<,>MONTH(TODAY())+1<,>DAY(TODAY())))"
.FormatConditions.Add Type:=xlExpression, _
Formula1:=Replace(sFormula, "<,>",
Application.International(xlListSeparator))
sFormula = "=AND(" & .Address(False, False) & _
">=TODAY()<,>" & .Address(False, False) & _
"<=DATE(YEAR(TODAY())<,>MONTH(TODAY())+3<,>DAY(TODAY())))"
.FormatConditions.Add Type:=xlExpression, _
Formula1:=Replace(sFormula, "<,>",
Application.International(xlListSeparator))
.FormatConditions(1).Interior.ColorIndex = 3
.FormatConditions(2).Interior.ColorIndex = 6
End With
End If
ws_exit:
Application.EnableEvents = True
End Sub
--
---
HTH
Bob
(there's no email, no snail mail, but somewhere should be gmail in my addy)