correct infinite loop

Hello

I am running a private sub in a worksheet (pasted below)
In this sub it highlights the colorindex of cells. I had to do this because 2003 only allows 3 conditional formats. This part works fine, but when I try to add and accumulators it gets stuck in an infinte loop. For some reason the for each will not break with any or all of the 4 accumulators. As soon as I take them out it works fine. Any help would be greatly appreciated

Thank You
Reece

Private Sub Worksheet_Change(ByVal Target As Range)
 
 Dim BSA1 As Variant
 Dim BSA2L1 As Variant
 Dim BSA2L2 As Variant
 
 Set BSA1 = Range("E6:E1500")
 Set BSA2L1 = Range("AB6:AB1500")
 Set BSA2L2 = Range("AX6:AX1500")
 
 Dim Cell As Variant
 
 Dim CellBSA1CK As Variant
 Dim CellBSA1King As Variant
 Dim CellBSA1Queen As Variant
 Dim CellBSA1Dbl As Variant
 
 Set CellBSA1CK = Range("M1")
 Set CellBSA1King = Range("M2")
 Set CellBSA1Queen = Range("M3")
 Set CellBSA1Dbl = Range("M4")
 
 CellBSA1CK.Value = 0
 CellBSA1King.Value = 0
 CellBSA1Queen.Value = 0
 CellBSA1Dbl.Value = 0
 
  
   For Each Cell In BSA1
    
        If Cell.Value > 138 And Cell.Value < 148 Then
            Cell.Interior.ColorIndex = 6
            CellBSA1Dbl.Value = CellBSA1Dbl.Value + 1      <----- Accumulator 1
        End If
        
        If Cell.Value > 156 And Cell.Value < 166 Then
            Cell.Interior.ColorIndex = 5
            CellBSA1Queen.Value = CellBSA1Queen.Value + 1 <----- Accumulator 2
        End If
        
        If Cell.Value > 196 And Cell.Value < 206 Then
            Cell.Interior.ColorIndex = 4
            CellBSA1King.Value = CellBSA1King.Value + 1 <----- Accumulator 3
        End If
        
        If Cell.Value > 217 And Cell.Value < 227 Then
            Cell.Interior.ColorIndex = 46
            CellBSA1CK.Value = CellBSA1CK.Value + 1 <----- Accumulator 4
        End If
        
        If Cell.Value < 138 Or Cell.Value >= 148 And Cell.Value <= 156 Or Cell.Value >= 166 And Cell.Value <= 196 Or Cell.Value >= 206 And Cell.Value <= 217 Or Cell.Value >= 227 Then
            Cell.Interior.ColorIndex = 0
        End If
        
        
    Next

End Sub

Please use code tags when posting code.

Turning events off might help:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim BSA1 As Variant
Dim BSA2L1 As Variant
Dim BSA2L2 As Variant

Set BSA1 = Range("E6:E1500")
Set BSA2L1 = Range("AB6:AB1500")
Set BSA2L2 = Range("AX6:AX1500")

Dim Cell As Variant

Dim CellBSA1CK As Variant
Dim CellBSA1King As Variant
Dim CellBSA1Queen As Variant
Dim CellBSA1Dbl As Variant

Set CellBSA1CK = Range("M1")
Set CellBSA1King = Range("M2")
Set CellBSA1Queen = Range("M3")
Set CellBSA1Dbl = Range("M4")

CellBSA1CK.Value = 0
CellBSA1King.Value = 0
CellBSA1Queen.Value = 0
CellBSA1Dbl.Value = 0

Application.EnableEvents = False

For Each Cell In BSA1

If Cell.Value > 138 And Cell.Value < 148 Then
Cell.Interior.ColorIndex = 6
CellBSA1Dbl.Value = CellBSA1Dbl.Value + 1 '<----- Accumulator 1
End If

If Cell.Value > 156 And Cell.Value < 166 Then
Cell.Interior.ColorIndex = 5
CellBSA1Queen.Value = CellBSA1Queen.Value + 1 '<----- Accumulator 2
End If

If Cell.Value > 196 And Cell.Value < 206 Then
Cell.Interior.ColorIndex = 4
CellBSA1King.Value = CellBSA1King.Value + 1 '<----- Accumulator 3
End If

If Cell.Value > 217 And Cell.Value < 227 Then
Cell.Interior.ColorIndex = 46
CellBSA1CK.Value = CellBSA1CK.Value + 1 '<----- Accumulator 4
End If

If Cell.Value < 138 Or Cell.Value >= 148 And Cell.Value <= 156 Or Cell.Value >= 166 And Cell.Value <= 196 Or Cell.Value >= 206 And Cell.Value <= 217 Or Cell.Value >= 227 Then
Cell.Interior.ColorIndex = 0
End If


Next

Application.EnableEvents = True

End Sub

Dom

So the code I posted doesn't work?

Dom

When you said you were in an infinite loop I assumed you meant the event code kept executing. If that's not the case a sample workbook would probably help.

Dom

My fault, turning events off should have been before this bit, not after it:

CellBSA1CK.Value = 0
CellBSA1King.Value = 0
CellBSA1Queen.Value = 0
CellBSA1Dbl.Value = 0

Dom