Conditional Format On Specific Range

[hobbiton73]

Hi, I wonder whether someone may be able to help me please.

I'm using the code below taken from an article on this site, which adds Conditional Formatting to the active sheet.

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 = Range(Target.Address)
End If
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case "G"
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case "AG"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "A"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "AR"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case "R"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next

End Sub

The problem I'm having is that it obviously changes all of the cells on the page which is causing a few problems, but after spending the best part of a day trying to find a solution, I'm out of ideas.

I just wondered whether someone may be able to look at this please and offer a little guidance on how I may go about setting a specific range, in this case W5:W100.

Any help would be gratefully received.

Many thanks and the kindest regards

Chris

[p45cal]

try:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Range("W5:W100").SpecialCells(xlCellTypeFormulas, 2)
On Error GoTo 0
If Not Rng1 Is Nothing Then
' Set Rng1 = Range(Target.Address)
'Else
' Set Rng1 = Range(Target.Address)
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case "G"
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case "AG"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "A"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "AR"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case "R"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next Cell
End If
End SubI've deleted some lines too.

[Bob Phillips]

Why do people insist on redoing the processing over and over again in event code, you should only change the cells changing

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range

On Error GoTo ws_exit

Application.EnableEvents = False

If Not Intersect(Target, Me.Range("W5:W100")) Is Nothing Then

For Each Cell In Target

Select Case Cell.Value

Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case "G"
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case "AG"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "A"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "AR"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case "R"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next Cell
End If

ws_exit:
Application.EnableEvents = True
End Sub

[p45cal]

Why do people insist on redoing the processing over and over again in event code, you should only change the cells changing
In this case, the cells being changed by the user are not the ones needing a format change (by definition - they've got formulae in them).

[hobbiton73]

Hi @p45cal, thank you very much for taking the time to reply to my post and for the solution and my apologies for not getting back to you sooner, but I've been at work today.

I tried the code that you kindly sent and the cells which are in the range are change, which is great, but unfortunately cells outside the range are also changed.

I admit I'm a little confused why this is the case, perhaps to the less experienced user i.e. me, your code looks fine.

Many thanks and kind regards

[p45cal]

Could you post your code as you have it now.
There isn't any other code which might change these other cells?
Is there any proper conditional formatting in those cells?

[hobbiton73]

Hi, @p45cal. Thank you very much for coming back to me so quickly. Please find the code below:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range

On Error GoTo ws_exit

Application.EnableEvents = False

If Not Intersect(Target, Me.Range("W5:W100")) Is Nothing Then

For Each Cell In Target

Select Case Cell.Value

Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case "G"
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case "AG"
Cell.Interior.ColorIndex = 10
Cell.Font.Bold = True
Case "A"
Cell.Interior.ColorIndex = 10
Cell.Font.Bold = True
Case "AR"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case "R"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next Cell
End If

ws_exit:
Application.EnableEvents = True
End Sub

The only other piece of code I have is within a module which copies data to the sheet, which then has the Conditional Formatting applied to it. For completeness, I've add this code below:

Sub BigMerge()
Set DestWB = ActiveWorkbook
DataSheet = "Combined"
DataColumn = "C"
NumberOfColumns = 34
StartRow = 5
FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If
For N = LBound(FileNames) To UBound(FileNames)
Set WB = Workbooks.Open(Filename:=FileNames(N))
For Each WS In WB.Worksheets
With WS
If .UsedRange.Cells.Count > 1 Then
dr = DestWB.Worksheets("Combined").Range("A" & Rows.Count).End(xlUp).Row + 1
Lastrow = .Range("A" & Rows.Count).End(xlUp).Row
.Range("A" & StartRow & ":AK" & Lastrow).Copy DestWB.Worksheets("Combined").Cells(dr, "A")
.Range("AL" & StartRow & ":AX" & Lastrow).Copy DestWB.Worksheets("Combined").Cells(dr, "AL")
End If
End With
Next WS

WB.Close savechanges:=False
Next N
End Sub

I hope this helps.

Once again many thanks and kind regards

[p45cal]

Your first snippet is not my code!
Try mine.

[hobbiton73]

Hi @p45cal, my sincere apologies.

Please find your code below which I've implemented in the sheets VB.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Cell As Range
Dim Rng1 As Range
On Error Resume Next
Set Rng1 = ActiveSheet.Range("W5:W100").SpecialCells(xlCellTypeFormulas, 2)
On Error GoTo 0
If Not Rng1 Is Nothing Then
' Set Rng1 = Range(Target.Address)
'Else
' Set Rng1 = Range(Target.Address)
For Each Cell In Rng1
Select Case Cell.Value
Case vbNullString
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
Case "G"
Cell.Interior.ColorIndex = 35
Cell.Font.Bold = True
Case "AG"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "A"
Cell.Interior.ColorIndex = 40
Cell.Font.Bold = True
Case "AR"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case "R"
Cell.Interior.ColorIndex = 3
Cell.Font.Bold = True
Case Else
Cell.Interior.ColorIndex = xlNone
Cell.Font.Bold = False
End Select
Next Cell
End If
End Sub

Unfortunately, when I add the data to the sheet, the conditional formatting doesn't take place.

Once again my apologies for the wrong code and thank you for your continued help.

Many thanks and kind regards

[p45cal]

Please find your code below which I've implemented in the sheets VB.
Which sheet? I'm presuming in the sheet called Combined?

Unfortunately, when I add the data to the sheet, the conditional formatting doesn't take place.1. Does the source sheet have formulae in column W which return the strings you want to be conditionally formatted?
2.Your current range is W5:W100, are there likely going to be more than 100 rows to look at?

[hobbiton73]

Hi, thank you very much for your continued help with this.

Unfortunately, the person whom I was helping to put this together has now changed the requirements, which means that this aspect of the sheet is now superfluous, for which I apologise, particularly after all the work you've done.

Could I therefore I ask please that you don't waste anymore time on this.

Once again my apologies

Many thanks and kind regards