Looping through a spreadsheet

[anon1m0us]

Hi;
I tried variuos codes, with no luck. Don't mind the extra variables.
it's left over from previous code which I have been trying.

Here is what I am trying to do:
When the excel opens, it should automatically check all the dates in
Column B. The difference between today's date and the date in Column B
will determine the color of the Cell.
Dim dDate As Date
Dim LRange As String
Dim dCalendar As Date
Dim dDiff As Integer
Dim rCell As Range, rng As Range
Dim vT5 As Variant
Dim rSource As Range
Dim rDest As Range



Private Sub Workbook_Open()

With Sheets("Non-Production")
Set rSource = .Range("B2:B" & .Range("B" & _
Rows.Count).End(xlUp).Row)
End With

For Each rCell In rSource
With rCell
dCalender = Cells(ActiveCell.Row, 2)
dDiff = DateDiff("d", dCalender, Date)
If dDiff = "" Then
Next rCell


If dDiff >= 30 Then
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 10
ElseIf (dDiff < 30) And (dDiff >= 15) Then
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 6
ElseIf dDiff <= 14 Then
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 3
Else
Cells(ActiveCell.Row, 2).Interior.ColorIndex = 3
End If
End With
Next rCell





End Sub

 

[merjet]

Delete: If dDiff = "" Then Next rCell
Replace all instances of Cells(ActiveCell.Row, 2) with rCell.

Hth,
Merjet

 

[Trevor Shuttleworth]

Try:

Private Sub Workbook_Open()
With Sheets("Non-Production")
Set rSource = .Range("B2:B" & .Range("B" & _
Rows.Count).End(xlUp).Row)
End With
For Each rCell In rSource
With rCell
On Error Resume Next
If .Value <> "" Then
dCalender = .Value
dDiff = DateDiff("d", dCalender, Date)
If dDiff <> "" Then
If dDiff >= 30 Then
.Interior.ColorIndex = 10
ElseIf (dDiff < 30) And (dDiff >= 15) Then
.Interior.ColorIndex = 6
ElseIf dDiff <= 14 Then
.Interior.ColorIndex = 3
Else
.Interior.ColorIndex = 12
End If
End If
End If
On Error GoTo 0
End With
Next 'rCell
End Sub


Regards

Trevor

 

[anon1m0us]

Thanks...It worked great!!!!!

 

[Trevor Shuttleworth]

You're welcome. Thanks for the feedback.