PDA

View Full Version : 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
"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

10545
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
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.

10547
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