Solved: VBA Conditional Formatting Range

[sawan202]

Hello,

Please can anyone tweak this code so that it work within a range of cell only, I have two sheets Apr - Sep and Oct - Mar, I need this code to work within range E8:GE23 on both of those sheets only.

Many thanks.


[VBA]

Option Compare Text '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
Case "A"
Cell.Interior.ColorIndex = 6
Case "B"
Cell.Interior.ColorIndex = 4
Case "S"
Cell.Interior.ColorIndex = 3
Case "T"
Cell.Interior.ColorIndex = 5
Case "C"
Cell.Interior.ColorIndex = 7
Case "U"
Cell.Interior.ColorIndex = 8
Case "O"
Cell.Interior.ColorIndex = 9
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next

End Sub


[/vba]

[Bob Phillips]

Put this in the ThisWorkbook code module

[vba]

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range

Select Case Sh.Name

Case "Apr - Sep", "Oct - Mar"

With Sh

On Error Resume Next
Set Rng1 = .Cells.SpecialCells(xlCellTypeFormulas, 1)
On Error GoTo 0

If Rng1 Is Nothing Then

Set Rng1 = .Range(Target.Address)
Else

Set Rng1 = Union(Target, Rng1)
End If

For Each Cell In Rng1

Select Case Cell.Value

Case vbNullString
Cell.Interior.ColorIndex = xlNone
Case "A"
Cell.Interior.ColorIndex = 6
Case "B"
Cell.Interior.ColorIndex = 4
Case "S"
Cell.Interior.ColorIndex = 3
Case "T"
Cell.Interior.ColorIndex = 5
Case "C"
Cell.Interior.ColorIndex = 7
Case "U"
Cell.Interior.ColorIndex = 8
Case "O"
Cell.Interior.ColorIndex = 9
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next
End With
End Select
End Sub
[/vba]

[sawan202]

xld - thanks for trying to fix this however the code you gave does not solve the problem as it still conditionally formats outside my range; it seems this is a tough one!

[Bob Phillips]

Maybe this then

[vba]


Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range

Select Case Sh.Name

Case "Apr - Sep", "Oct - Mar"

With Sh

On Error Resume Next
Set Rng1 = .Range("E8:GE23").SpecialCells(xlCellTypeFormulas, 1)
On Error Goto 0

If Rng1 Is Nothing Then

Set Rng1 = .Range(Target.Address)
Else

Set Rng1 = Union(Target, Rng1)
End If

For Each Cell In Rng1

Select Case Cell.Value

Case vbNullString
Cell.Interior.ColorIndex = xlNone
Case "A"
Cell.Interior.ColorIndex = 6
Case "B"
Cell.Interior.ColorIndex = 4
Case "S"
Cell.Interior.ColorIndex = 3
Case "T"
Cell.Interior.ColorIndex = 5
Case "C"
Cell.Interior.ColorIndex = 7
Case "U"
Cell.Interior.ColorIndex = 8
Case "O"
Cell.Interior.ColorIndex = 9
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next
End With
End Select
End Sub [/vba]

[sawan202]

xld - I found the solution to this problem finally, I had posted this question over to another forum and someone came up with line of code that did the trick!

Thanks for trying


[VBA]

If Intersect(Target, Range("E8:GE23")) Is Nothing Then Exit Sub

[/VBA]