Someone is probably going to post a more efficient way to do this, but this will work, and should be pretty easy for you to extend if you add more columns that are valid:
Code:Private Sub Worksheet_Change(ByVal Target As Range) Dim Cell As Range Dim Rng1 As Range 'Check for validity If Not Target.Columns.Count = 1 Then GoTo EarlyExit If Not Intersect(Target, ActiveSheet.Columns("C")) Is Nothing Then GoTo AllGood If Not Intersect(Target, ActiveSheet.Columns("E")) Is Nothing Then GoTo AllGood If Not Intersect(Target, ActiveSheet.Columns("H")) Is Nothing Then GoTo AllGood If Not Intersect(Target, ActiveSheet.Columns("G")) Is Nothing Then GoTo AllGood 'All tests failed, so exit GoTo EarlyExit AllGood: 'Looks like things are good, let's go! On Error Resume Next Set Rng1 = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 1) On Error GoTo 0 If Rng1 Is Nothing Then Set Rng1 = Range(Target.Address) Else Set Rng1 = Union(Range(Target.Address), Rng1) End If For Each Cell In Rng1 Select Case Cell.Value Case vbNullString Cell.Interior.ColorIndex = xlNone Cell.Font.Bold = False Case 0.9 To 1 Cell.Interior.ColorIndex = 4 Cell.Font.Bold = True Case 0.8 To 0.89999999999999 Cell.Interior.ColorIndex = 36 Cell.Font.Bold = True Case 0.1 To 0.799999999999999 Cell.Interior.ColorIndex = 3 Cell.Font.Bold = True Case 0 Cell.Interior.ColorIndex = 6 Cell.Font.Bold = True Case Else Cell.Interior.ColorIndex = xlNone Cell.Font.Bold = False End Select Next EarlyExit: End Sub
Bookmarks