VBA Formatting

T

thedeadzeds

New member
Joined
Oct 25, 2011
Messages
37
Reaction score
0
Points
0
Excel Version(s)
2016
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


Code: 
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
 
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
 
or:
Code: 
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
 
You must log in or register to reply here.
Back
Top