Dave,

How about this?

Sub Test()
Sub Test()
Dim iLastRow As Long
Dim i As Long
Dim cell As Range
Const kCol As String = "AC"

iLastRow = Cells(Rows.Count, kCol).End(xlUp).Row
For i = 1 To iLastRow - 1
Cells(i, kCol).Interior.ColorIndex = xlColorIndexNone
On Error Resume Next
Set cell = Nothing
Set cell = Range(kCol & i & ":" & kCol & iLastRow).Find(Cells(i,
kCol).Value)
On Error GoTo 0
If Not cell Is Nothing Then
If cell.Offset(0, -2).Value = 1 And cell.Address < Cells(i,
kCol).Address Then
Cells(i, kCol).Interior.ColorIndex = 3
End If
End If
Next i

End Sub


--

HTH

RP
(remove nothere from the email address if mailing direct)


"Dave" wrote in message
...
Hi David

Thanks for your replies

I've applied both the formulas with no luck

Hope I can be more clear with this post, I have dug out an old post off a
floppy disk from a couple of years ago. I was working on a similar task
when
I send a post and had replies from Patrick Molloy, which work ok. I have
put
another example and the code below.

R AA AC
1 1 JOHN < this cell ( Would be Fill colour Red because
AA4
= 1
2 2 JANE < this cell Would Not be red
3 0 JANE < this cell Would Not be red
4 1 JOHN < this cell Would Not be red because AA5 is not a
number 1
5 0 JOHN < this cell ( Would be Fill colour Red because
AA7
= 1
6 5 JANE < this cell ( Would be Fill colour Red because
AA8
= 1
7 1 JOHN < this cell Would Not be red
8 1 JANE < this cell Would Not be red

I have tried this code it works but it works up the columns, maybe then I
was entering new data at the top of the sheet. I would like to work down
the
sheet and change the Font color to Fill color red.

Sub Fillred()
Dim aText() As String
Dim pointer As Long
Dim i As Long
Dim rw As Long
Dim clText As String
Dim clVal As String
clText = "AC"
clVal = "AA"
rw = 4
Do Until Cells(rw, clVal) = ""
If pointer 0 Then
For i = 1 To UBound(aText)
If aText(i) = Cells(rw, clText) Then
Cells(rw, clText).Font.Color = vbRed
aText(i) = ""
Exit For
End If
Next
End If
If Cells(rw, clVal) = 1 Then
pointer = pointer + 1
ReDim Preserve aText(1 To pointer)
aText(pointer) = Cells(rw, clText)
End If
rw = rw + 1
Loop
End Sub

Thanks in Advance

Dave