Cell Colouring in VBA

**michaelrjb** · 08-14-2013, 08:09 AM

Hi all

I've been experimenting with the below. Can someone help me modify it to include two sheets (Summary & Detailed), with only specific cells on each sheet.

Option Compare Text [COLOR=darkgreen]'A=a, B=b, ... Z=z
Option Explicit
 
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 "Tom", "Joe", "Paul"
            Cell.Interior.ColorIndex = 3
            Cell.Font.Bold = True
        Case "Smith", "Jones"
            Cell.Interior.ColorIndex = 4
            Cell.Font.Bold = True
        Case 1, 3, 7, 9
            Cell.Interior.ColorIndex = 5
            Cell.Font.Bold = True
        Case 10 To 25
            Cell.Interior.ColorIndex = 6
            Cell.Font.Bold = True
        Case 26 To 99
            Cell.Interior.ColorIndex = 7
            Cell.Font.Bold = True
        Case Else
            Cell.Interior.ColorIndex = xlNone
            Cell.Font.Bold = False
        End Select
    Next
    
End Sub

Thanks

**SamT** · 08-14-2013, 08:33 AM

"Cell" might be a VBA Keyword in the future. Change all "Cell" Variables to "Cel"

    Dim Cel As Range    
      Dim Rng1 As Range

Dim MySheets As Collection
Dim Sht As Worksheet
With My Sheets
   .Add Sheets("Summary")
   .Add Sheets("Detailed")
End With

For Each Sht in MySheets    
    On Error Resume Next
    Set Rng1 = Sht.Cells.SpecialCells(xlCellTypeFormulas, 1)
'
'
'
Next Sht
End Sub

Alternately

Private Sub Worksheet_Change(ByVal Target As Range)
   Colorize Sheets("Summary"), Target
   ColorizeSheets("Detailed"), Target
End Sub

Private Function Colorize(Sht As Worksheet, Rng2 As Range)
 Dim Cel As Range
    Dim Rng1 As Range
    
    On Error Resume Next
    Set Rng1 = Sht.Cells.SpecialCells(xlCellTypeFormulas, 1)
    On Error Goto 0
    If Rng1 Is Nothing Then
        Set Rng1 = Range(Rng2.Address)
    Else
        Set Rng1 = Union(Range(Rng2.Address), Rng1)
    End If
    For Each Cel In Rng1
        Select Case Cel.Value
        'Case vbNullString ' Included in Case Else
        '    Cell.Interior.ColorIndex = xlNone
        '    Cell.Font.Bold = False
        Case "Tom", "Joe", "Paul"
            Cel.Interior.ColorIndex = 3
            Cel.Font.Bold = True
        Case "Smith", "Jones"
            Cel.Interior.ColorIndex = 4
            Cel.Font.Bold = True
        Case 1, 3, 7, 9
            Cel.Interior.ColorIndex = 5
            Cel.Font.Bold = True
        Case 10 To 25
            Cel.Interior.ColorIndex = 6
            Cel.Font.Bold = True
        Case 26 To 99
            Cel.Interior.ColorIndex = 7
            Cel.Font.Bold = True
        Case Else
            Cel.Interior.ColorIndex = xlNone
            Cel.Font.Bold = False
        End Select
    Next

**michaelrjb** · 08-15-2013, 03:41 AM

Originally Posted by SamT

"Cell" might be a VBA Keyword in the future. Change all "Cell" Variables to "Cel"

    Dim Cel As Range      Dim Rng1 As Range 

Dim MySheets As Collection
Dim Sht As Worksheet
With My Sheets
   .Add Sheets("Summary")
   .Add Sheets("Detailed")
End With

For Each Sht in MySheets     
    On Error Resume Next 
    Set Rng1 = Sht.Cells.SpecialCells(xlCellTypeFormulas, 1) 
'
'
'
Next Sht
End Sub

Alternately

Private Sub Worksheet_Change(ByVal Target As Range) 
   Colorize Sheets("Summary"), Target
   ColorizeSheets("Detailed"), Target
End Sub

Private Function Colorize(Sht As Worksheet, Rng2 As Range)
 Dim Cel As Range 
    Dim Rng1 As Range 
     
    On Error Resume Next 
    Set Rng1 = Sht.Cells.SpecialCells(xlCellTypeFormulas, 1) 
    On Error Goto 0 
    If Rng1 Is Nothing Then 
        Set Rng1 = Range(Rng2.Address) 
    Else 
        Set Rng1 = Union(Range(Rng2.Address), Rng1) 
    End If 
    For Each Cel In Rng1 
        Select Case Cel.Value 
        'Case vbNullString ' Included in Case Else
        '    Cell.Interior.ColorIndex = xlNone 
        '    Cell.Font.Bold = False 
        Case "Tom", "Joe", "Paul" 
            Cel.Interior.ColorIndex = 3 
            Cel.Font.Bold = True 
        Case "Smith", "Jones" 
            Cel.Interior.ColorIndex = 4 
            Cel.Font.Bold = True 
        Case 1, 3, 7, 9 
            Cel.Interior.ColorIndex = 5 
            Cel.Font.Bold = True 
        Case 10 To 25 
            Cel.Interior.ColorIndex = 6 
            Cel.Font.Bold = True 
        Case 26 To 99 
            Cel.Interior.ColorIndex = 7 
            Cel.Font.Bold = True 
        Case Else 
            Cel.Interior.ColorIndex = xlNone 
            Cel.Font.Bold = False 
        End Select 
    Next

Cheers for this, is there a way to narrow down the fields that it looks at to only G5:g32 & H5:h32 on the Summary sheet?

**SamT** · 08-16-2013, 05:55 PM

Private Function Colorize(Sht As Worksheet)
 Dim Cel As Range
     For Each Cel In Sht.Range("G5:H32")
        Select Case Cel.Value
        'Case vbNullString ' Included in Case Else
        '    Cell.Interior.ColorIndex = xlNone
        '    Cell.Font.Bold = False
        Case "Tom", "Joe", "Paul"
            Cel.Interior.ColorIndex = 3
            Cel.Font.Bold = True
        Case "Smith", "Jones"
            Cel.Interior.ColorIndex = 4
            Cel.Font.Bold = True
        Case 1, 3, 7, 9
            Cel.Interior.ColorIndex = 5
            Cel.Font.Bold = True
        Case 10 To 25
            Cel.Interior.ColorIndex = 6
            Cel.Font.Bold = True
        Case 26 To 99
            Cel.Interior.ColorIndex = 7
            Cel.Font.Bold = True
        Case Else
            Cel.Interior.ColorIndex = xlNone
            Cel.Font.Bold = False
        End Select
    Next

**michaelrjb** · 09-04-2013, 08:40 AM

For the life of me i cannot get me to work.

On the 'Summary' Sheet the 'Previous Month' and 'Current Month' in F5:F7 and G5:G7 need to change depending on the value.

So, 0.01 - 0.70 are RED, 0.71 - 0.89 are YELLOW and 0.90 - 1.00 are GREEN.

Major Kudos to anyone who can get this to work.

Thanks

ExampleSS.xlsx

**SamT** · 09-04-2013, 11:00 AM

Try this in the ThisWorkbook Code Module

Option Explicit
 
Private Sub Workbook_SheetChange(ByVal Sht As Object, ByVal Target As Range)
 
Dim Cel As Range
Dim Rng1 As Range
Dim FirstCell As Range
Dim LastCell As Range
 
  'If block designed for consistancy, not efficency.
  'All Ranges set to Sht.Range for Sheet specificity of Rng1 assignment
  If Sht.Name = "Summary" Then
    Set FirstCel = Sht.Range("C5")
    Set LastCell = Sht.Range("A" & Rows.Count).End(xlUp).Offset(0, 4)
    Set Rng1 = Sht.Range(FirstCell, LastCell)
  ElseIf Sht.Name = "Detailed" Then
    Set FirstCell = Sht.Range("A:A").Find("Oracle Sap Upgrade").Offset(1, 1)
    Set LastCell = Sht.Range("A" & Rows.Count).End(xlUp).Offset(0, 1)
    Set Rng1 = Sht.Range(FirstCell, LastCell)
  Else: Exit Sub
  End If
    
  For Each Cel In Rng1
    Select Case Cel.Value
      Case "Henry Archer", "Helen Allsop", "Jon Anderson"
        Cel.Interior.ColorIndex = 3
        Cel.Font.Bold = True
      Case "Mark Kiddie", "Joseph Rushton"
        Cel.Interior.ColorIndex = 4
        Cel.Font.Bold = True
      Case 1, 3, 7, 9
        Cel.Interior.ColorIndex = 5
        Cel.Font.Bold = True
      Case 10 To 25
        Cel.Interior.ColorIndex = 6
        Cel.Font.Bold = True
      Case 26 To 99
        Cel.Interior.ColorIndex = 7
        Cel.Font.Bold = True
      Case Else
        Cel.Interior.ColorIndex = xlNone
        Cel.Font.Bold = False
    End Select
  Next

End Sub

**michaelrjb** · 09-04-2013, 02:05 PM

Originally Posted by SamT

Try this in the ThisWorkbook Code Module

Option Explicit
 
Private Sub Workbook_SheetChange(ByVal Sht As Object, ByVal Target As Range)
 
Dim Cel As Range
Dim Rng1 As Range
Dim FirstCell As Range
Dim LastCell As Range
 
  'If block designed for consistancy, not efficency.
  'All Ranges set to Sht.Range for Sheet specificity of Rng1 assignment
  If Sht.Name = "Summary" Then
    Set FirstCel = Sht.Range("C5")
    Set LastCell = Sht.Range("A" & Rows.Count).End(xlUp).Offset(0, 4)
    Set Rng1 = Sht.Range(FirstCell, LastCell)
  ElseIf Sht.Name = "Detailed" Then
    Set FirstCell = Sht.Range("A:A").Find("Oracle Sap Upgrade").Offset(1, 1)
    Set LastCell = Sht.Range("A" & Rows.Count).End(xlUp).Offset(0, 1)
    Set Rng1 = Sht.Range(FirstCell, LastCell)
  Else: Exit Sub
  End If
    
  For Each Cel In Rng1
    Select Case Cel.Value
      Case "Henry Archer", "Helen Allsop", "Jon Anderson"
        Cel.Interior.ColorIndex = 3
        Cel.Font.Bold = True
      Case "Mark Kiddie", "Joseph Rushton"
        Cel.Interior.ColorIndex = 4
        Cel.Font.Bold = True
      Case 1, 3, 7, 9
        Cel.Interior.ColorIndex = 5
        Cel.Font.Bold = True
      Case 10 To 25
        Cel.Interior.ColorIndex = 6
        Cel.Font.Bold = True
      Case 26 To 99
        Cel.Interior.ColorIndex = 7
        Cel.Font.Bold = True
      Case Else
        Cel.Interior.ColorIndex = xlNone
        Cel.Font.Bold = False
    End Select
  Next

End Sub

I've modified the above a little to suit my purposes. However the basic code is still yours SamT. I still cant get it to fire tho. Do i need to call it?

Implementation in attached.

ExampleSSM.xlsm

**ZVI** · 09-04-2013, 03:25 PM

There are some typos in your code vs the suggested by SamT.
Replace:
1. Workbook_Sheet_Change by Workbook_SheetChange
2. Case 0.7 - 0.89 by Case 0.7 To 0.89 and so on for other intervals
3. Case R by Case "R" and the same is for A & G

**SamT** · 09-04-2013, 04:23 PM

Fix the Typos

I looked at you latest example. Its Ranges have no relation to the code we have been developing for you. Thanks for the extra typing practice.

**snb** · 09-05-2013, 01:04 AM

  with Rng1
    .Interior.ColorIndex = xlNone 
    .Font.Bold = False
  end with 

  For Each it In Rng1 
    Select Case it.Value 
    Case "Henry Archer", "Helen Allsop", "Jon Anderson" 
      it.interior.ColorIndex = 3 
    Case "Mark Kiddie", "Joseph Rushton" 
      it.Interior.ColorIndex = 4 
    Case 1, 3, 7, 9 
      it.Interior.ColorIndex = 5 
    Case 10 To 25 
      it.Interior.ColorIndex = 6 
    Case 26 To 99 
      it.Interior.ColorIndex = 7 
    End Select 
    if it.interior.colorindex<>xlnone then it.font.bold=true
  Next

Thread: Cell Colouring in VBA

Thread Tools

Display

Cell Colouring in VBA

Posting Permissions