VBA Formatting

[thedeadzeds]

Hi All,

I have this code that works great but works on the whole worksheet.

Can this code be adapted to to use only on columns, C, E, G and H?

Many thanks
Craig

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim Cell As Range
Dim Rng1 As Range
     
    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
 
End Sub

[Ken Puls]

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:

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

[snb]

or:

Private Sub Worksheet_Change(ByVal Target As Range)
  on error resume next
  For Each cl In Intersect(UsedRange.SpecialCells(-4123, 1), Range("C1,E1,G1,H1").EntireColumn)
        cl.Interior.ColorIndex = xlNone
        If cl <= 1 Then cl.Interior.ColorIndex = Choose(1 + (10 * cl), 6, 3, 3, 3, 3, 3, 3, 3, 36, 4, 4)
        cl.Font.Bold = cl <= 1
   Next
End Sub

[Ken Puls]

Someone is probably going to post a more efficient way to do this

See what I mean? Nice work snb!