I currently have this code, where HMLoc is the starting point for a
color paste at C6. Instead of having this a constant field, I need it
to search for today's date in the cell above it (C5) (The dates are
given in the range C5:BO5), and then color accordingly. I have
struggled with this all morning and can't get it to work the way I want
it. Please help me!


Option Explicit
Const LegendLoc = "BH3"
Const HMLoc = "C6"
Const None = 0

Sub ColorHM()

Dim theRow As Integer
Dim theCol As Integer
Dim NumX As Single
Dim Color1 As Integer
Dim Color2 As Integer
Dim Color3 As Integer
Dim Color4 As Integer
Dim Color6 As Integer
Dim ColorB As Integer
Dim Prod01 As Single
Dim Prod02 As Single
Dim Prod03 As Single
Dim Prod04 As Single
Dim Prod06 As Single
Dim ProdBal As Single
Dim Fcst01 As Single
Dim Fcst02 As Single
Dim Fcst03 As Single
Dim Fcst04 As Single
Dim Fcst06 As Single
Dim FcstBal As Single
Dim theCell

Color1 = Range(LegendLoc).Offset(0, 0).Interior.ColorIndex
Color2 = Range(LegendLoc).Offset(1, 0).Interior.ColorIndex
Color3 = Range(LegendLoc).Offset(2, 0).Interior.ColorIndex
Color4 = Range(LegendLoc).Offset(3, 0).Interior.ColorIndex
Color6 = Range(LegendLoc).Offset(4, 0).Interior.ColorIndex
ColorB = Range(LegendLoc).Offset(5, 0).Interior.ColorIndex

Prod01 = Sheets("HM Calcs").Range("B6").Value
Prod02 = Sheets("HM Calcs").Range("C6").Value
Prod03 = Sheets("HM Calcs").Range("D6").Value
Prod04 = Sheets("HM Calcs").Range("E6").Value
Prod06 = Sheets("HM Calcs").Range("F6").Value
ProdBal = Sheets("HM Calcs").Range("G6").Value
Fcst01 = Sheets("HM Calcs").Range("H6").Value
Fcst02 = Sheets("HM Calcs").Range("I6").Value
Fcst03 = Sheets("HM Calcs").Range("J6").Value
Fcst04 = Sheets("HM Calcs").Range("K6").Value
Fcst06 = Sheets("HM Calcs").Range("L6").Value
FcstBal = Sheets("HM Calcs").Range("M6").Value

NumX = 0#

Range(HMLoc).Select
For Each theCell In Selection

For theCol = 0 To 55
For theRow = 0 To 2

If theCell.Offset(theRow, theCol).Value = "X" Or
theCell.Offset(theRow, theCol).Value = "1/2" Or theCell.Offset(theRow,
theCol).Value = "Y" Then
If theCell.Offset(theRow, theCol).Value = "X" Then
NumX = NumX + 1
ElseIf theCell.Offset(theRow, theCol).Value = "1/2" Then
NumX = NumX + 0.5
ElseIf theCell.Offset(theRow, theCol).Value = "Y" Then
NumX = NumX + 0.9574
End If
With theCell.Offset(theRow, theCol).Interior
.Pattern = xlSolid
If NumX FcstBal Then
.Pattern = xlAutomatic
.ColorIndex = None
ElseIf NumX Fcst06 Then
.ColorIndex = ColorB
ElseIf NumX Fcst04 Then
.ColorIndex = Color6
ElseIf NumX Fcst03 Then
.ColorIndex = Color4
ElseIf NumX Fcst02 Then
.ColorIndex = Color3
ElseIf NumX Fcst01 Then
.ColorIndex = Color2
ElseIf NumX ProdBal Then
.ColorIndex = Color1
ElseIf NumX Prod06 Then
.ColorIndex = ColorB
ElseIf NumX Prod04 Then
.ColorIndex = Color6
ElseIf NumX Prod03 Then
.ColorIndex = Color4
ElseIf NumX Prod02 Then
.ColorIndex = Color3
ElseIf NumX Prod01 Then
.ColorIndex = Color2
Else
.ColorIndex = Color1
End If
End With
Else
With theCell.Offset(theRow, theCol).Interior
.Pattern = xlAutomatic
.ColorIndex = None
End With
End If

Next theRow
Next theCol

Next theCell
Range("A1").Select

End Sub