VBA Code; need linked cells to change color if condition met

[JVANWORTH]

This calls for VBA Code knowledge I don’t have.

I’m revisiting an old High School Scheduling project with a clearer objective.

Microsoft Office EXCEL 2003

How do I get the cells that are linked to another worksheet to change colors
if a condition is met. I will need about four colors to correspond with
approximately 15 plus conditions.

Streamlined Example Follows:

In the workbook I have two (2) worksheets named: English & Math (I will be
adding more Wrkshts as demand grows). Each has a pull down menu to assign
teachers classes for the semester.

Example of English Wrksht:
A B
1 Bicks English Art (column B selected from pull down menu)
2 Jotos 9th Lit
3 Pordan S-CAP

Math Wrksht:
A B
1 Adleman Algebra (column B selected from pull down menu)
2 Fuller Geometry
3 Johnson CAHSEE Math

And so on

In another Wrksht called Grade 9 I link up to combine English and Math to
present data in a format with color.
A B C
1 ENG Bicks English Art (cell needs blue) – (B1 & C1
link to English)
2 MATH Fuller Geometry (cell needs light green)
3 MATH Johnson CAHSEE Math (cell needs pink)
4 ENG Jotos 9th Lit (cell in light green)
5 ENG Pordon S-Cap (cell in light yellow)

As I manipulate English and Math wrkshts and change courses I need Grade 9
Wrksht to change colors. Wrkshts English and Math will not have color.


PS……Thanks to Bob, Rick “MVPâ€, and Toppers for your past help with code. I
just couldn’t get it to work with the example above….I think this paints a
better picture

 

[Bob Phillips]

Add this to the Grade 9 worksheet

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "B:B" '<== change to suit

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
.Interior.ColorIndex = xlColorIndexNone

Select Case .Value

Case "Geometry": .Interior.ColorIndex = 35 'light green
Case "CAHSEE Math": .Interior.ColorIndex = 7 'pink
Case "9th Lit": .Interior.ColorIndex = 10 'green
Case "S-Cap": .Interior.ColorIndex = 36 'light yellow
'etc.
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

'This is worksheet event code, which means that it needs to be
'placed in the appropriate worksheet code module, not a standard
'code module. To do this, right-click on the sheet tab, select
'the View Code option from the menu, and paste the code in.


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[JVANWORTH]

Bob,

Did you get my workbook I e-mailed?

Add this to the Grade 9 worksheet

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "B:B" '<== change to suit

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
.Interior.ColorIndex = xlColorIndexNone

Select Case .Value

Case "Geometry": .Interior.ColorIndex = 35 'light green
Case "CAHSEE Math": .Interior.ColorIndex = 7 'pink
Case "9th Lit": .Interior.ColorIndex = 10 'green
Case "S-Cap": .Interior.ColorIndex = 36 'light yellow
'etc.
End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

'This is worksheet event code, which means that it needs to be
'placed in the appropriate worksheet code module, not a standard
'code module. To do this, right-click on the sheet tab, select
'the View Code option from the menu, and paste the code in.


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[JVANWORTH]

Bob,

I'm getting hung up on the line"

End with

in the code that you sent me

 

[Dave Peterson]

Remember that you need an "End Select" statement, too:

Private Sub Worksheet_Change(ByVal Target As Range)
Const WS_RANGE As String = "B:B" '<== change to suit

On Error GoTo ws_exit
Application.EnableEvents = False

If Not Intersect(Target, Me.Range(WS_RANGE)) Is Nothing Then
With Target
.Interior.ColorIndex = xlColorIndexNone

Select Case .Value

Case "Geometry": .Interior.ColorIndex = 35 'light green
Case "CAHSEE Math": .Interior.ColorIndex = 7 'pink
Case "9th Lit": .Interior.ColorIndex = 10 'green
Case "S-Cap": .Interior.ColorIndex = 36 'light yellow
'etc.

End Select '<-- added

End With
End If

ws_exit:
Application.EnableEvents = True
End Sub

 

[JVANWORTH]

Dave,

I made the change, but still no luck with the color change. I'll keep
plugging away.
Would you mind looking at the workbook I created. I inserted windows to
give the reader an idea what I'm looking for.

 

[Bob Phillips]

No I didn't.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Dave Peterson]

I don't open workbooks from others.

You may want to post your existing code in plain text.

 

[JVANWORTH]

Understood

Thru this discussion I was given the following code to work with multiple
spredsheets:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:CZ800")) _
Is Nothing Then Exit Sub
Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
icolor = 3
Case "ENG 10", "MATH 10", "SCI 10"
icolor = 4
Case "ENG 11", "MATH 11", "SCI 11"
icolor = 5
Case "ENG 12", "MATH 12", "SCI 12"
icolor = 6
Case Else
End Select
Target.Interior.ColorIndex = icolor
For i = 1 To 3
With Worksheets("Sheet" & i)
For Each cell In .Range("A1: CZ800 ")
If cell.Value = Target.Value Then
cell.Interior.ColorIndex = icolor
End If
Next cell
End With
Next i

End Sub

It works really well if I only have Sheets 1, 2, 3. If I create a new sheet
called "Sch" and place 'MATH 11' in A1, then link A1 from Sheet 1 to it it
will turn blue like it should. However, if I change A1 in Sheet "Sch" to
'Math 9', A1 in Sheet 1 remains blue but says 'Math 9'. Is there any way to
get the Sheet 1 to recalculate or reprocess when I make changes in Sheet
"Sch"?????

 

[JVANWORTH]

Dave & Bob,

I added Daves extra line "End Select". Intial links work fine. But the
issue remains the same. When I change a cell in English or Math the linked
cell in Grade 9 will not change color (text changes, no color change)

 

[Dave Peterson]

Sometimes, it's not always best to loop through cells. In your case, you're
looping through A1:CZ800 (83200 cells!) -- and you're doing it 3 times.

There are faster ways to find stuff. One of those faster ways is to use .Find.

I think that this does what you want. Test it to make sure.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim iColor As Long
Dim cell As Range
Dim i As Long
Dim FoundCell As Range
Dim FirstAddress As String

'one cell at a time!
If Target.Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("A1:CZ800")) Is Nothing Then Exit Sub

iColor = 9999 'just an indicator

Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
iColor = 3
Case "ENG 10", "MATH 10", "SCI 10"
iColor = 4
Case "ENG 11", "MATH 11", "SCI 11"
iColor = 5
Case "ENG 12", "MATH 12", "SCI 12"
iColor = 6
Case Else
'do nothing
End Select

If iColor = 9999 Then
'do nothing
Else
Target.Interior.ColorIndex = iColor
For i = 1 To 3
With Worksheets("Sheet" & i)
With .Range("a1:CZ800")
Set FoundCell = .Cells.Find(What:=Target.Value, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
'not found in that range
Else
FirstAddress = FoundCell.Address
Do
FoundCell.Interior.ColorIndex = iColor
Set FoundCell = .FindNext(after:=FoundCell)
If FoundCell.Address = FirstAddress Then
'found the first one again, get out
Exit Do
End If
Loop
End If
End With
End With
Next i
End If

End Sub

============
Since you're using xl2003, you can do Edit|Replace to change formats, too. Next
time you're in the Edit|replace dialog, click on the Options button to expand
the, er, options. You'll see that you can search by format and replace format,
too.

This will work in xl2003+ (not in earlier versions):

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iColor As Long
Dim cell As Range
Dim i As Long
Dim FoundCell As Range
Dim FirstAddress As String

'one cell at a time!
If Target.Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("A1:CZ800")) Is Nothing Then Exit Sub

iColor = 9999 'just an indicator

Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
iColor = 3
Case "ENG 10", "MATH 10", "SCI 10"
iColor = 4
Case "ENG 11", "MATH 11", "SCI 11"
iColor = 5
Case "ENG 12", "MATH 12", "SCI 12"
iColor = 6
Case Else
'do nothing
End Select

If iColor = 9999 Then
'do nothing
Else
Target.Interior.ColorIndex = iColor
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
Application.ReplaceFormat.Interior.ColorIndex = iColor
For i = 1 To 3
With Worksheets("Sheet" & i)
With .Range("a1:CZ800")
.Cells.Replace _
What:=Target.Value, _
Replacement:=UCase(Target.Value), _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=True
End With
End With
Next i
End If
End Sub

And that second version should work pretty fast.

Understood

Thru this discussion I was given the following code to work with multiple
spredsheets:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("A1:CZ800")) _
Is Nothing Then Exit Sub
Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
icolor = 3
Case "ENG 10", "MATH 10", "SCI 10"
icolor = 4
Case "ENG 11", "MATH 11", "SCI 11"
icolor = 5
Case "ENG 12", "MATH 12", "SCI 12"
icolor = 6
Case Else
End Select
Target.Interior.ColorIndex = icolor
For i = 1 To 3
With Worksheets("Sheet" & i)
For Each cell In .Range("A1: CZ800 ")
If cell.Value = Target.Value Then
cell.Interior.ColorIndex = icolor
End If
Next cell
End With
Next i

End Sub

It works really well if I only have Sheets 1, 2, 3. If I create a new sheet
called "Sch" and place 'MATH 11' in A1, then link A1 from Sheet 1 to it it
will turn blue like it should. However, if I change A1 in Sheet "Sch" to
'Math 9', A1 in Sheet 1 remains blue but says 'Math 9'. Is there any way to
get the Sheet 1 to recalculate or reprocess when I make changes in Sheet
"Sch"?????

 

[JVANWORTH]

Dave,
Thanks for all your help and time.

The linked cell still will not change to proper color (text changes). Maybe
I should stream line the objective and move forward from there.

I deleted Sheets 2 and 3 to keep it simple. The only sheets I have are
"Sch" and "Sheet 1". "Sch" sheet will have no color.

IF A1 from "Sch" is 'Math 9' and A1 from "Sheet 1" is linked to A1 of "Sch"
your code executes for the initial linking (turns A1 in "Sheet 1" red)

If I change A1 in "Sch" to Math 10 the text in the linked cell (A1 in Sheet
1) changes but not the color.

I need to figure out how to get the workbook to do this automatically.
Somehow refresh itself.

I'll keep grinding away at it,

John

 

[Dave Peterson]

Try that first code that I suggested--not the code specific to xl2003.

Just to make it more clear--this worked fine for me:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim iColor As Long
Dim cell As Range
Dim i As Long
Dim FoundCell As Range
Dim FirstAddress As String

'one cell at a time!
If Target.Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("A1:CZ800")) Is Nothing Then Exit Sub

iColor = 9999 'just an indicator

Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
iColor = 3
Case "ENG 10", "MATH 10", "SCI 10"
iColor = 4
Case "ENG 11", "MATH 11", "SCI 11"
iColor = 5
Case "ENG 12", "MATH 12", "SCI 12"
iColor = 6
Case Else
'do nothing
End Select

If iColor = 9999 Then
'do nothing
Else
Target.Interior.ColorIndex = iColor
For i = 1 To 1 'or 3????
With Worksheets("Sheet" & i)
With .Range("a1:CZ800")
Set FoundCell = .Cells.Find(What:=Target.Value, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
'not found in that range
Else
FirstAddress = FoundCell.Address
Do
FoundCell.Interior.ColorIndex = iColor
Set FoundCell = .FindNext(after:=FoundCell)
If FoundCell.Address = FirstAddress Then
'found the first one again, get out
Exit Do
End If
Loop
End If
End With
End With
Next i
End If

End Sub

 

[JVANWORTH]

Dave,

Do I need to turn something on internally in the workbook (regeneration,
recalculation)? I can not get the linked cell to change to the correct color
when I change the source cell. The link cell will only change to the correct
color when I open it and then close it.

John

 

[Dave Peterson]

If you're changing the cell by typing then the Worksheet_change event should
fire and cause the other changes to take place.

If you've turned off events somewhere else (and that's consistent with your
description), you can turn events back on via:

Inside the VBE
hit ctrl-g (to see the immediate window)
type this and hit enter:
application.enableevents = true
(The test it to see if it works.)

The real problem is to find out where you turned it off and where you should
turn it back on!

Did you add something to the suggested code????

 

[JVANWORTH]

Dave,

I followed your instructions with the ctrl-g and added
"application.enableevents = true" to the immediate window, then <enter>. I
could not detect a change. The linked cell displays the new text but the
will not cahnge.

I do not believe I modified the code: (see below)


Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim iColor As Long
Dim cell As Range
Dim i As Long
Dim FoundCell As Range
Dim FirstAddress As String

'one cell at a time!
If Target.Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("A1:CZ800")) Is Nothing Then Exit Sub

iColor = 9999 'just an indicator

Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
iColor = 3
Case "ENG 10", "MATH 10", "SCI 10"
iColor = 4
Case "ENG 11", "MATH 11", "SCI 11"
iColor = 5
Case "ENG 12", "MATH 12", "SCI 12"
iColor = 6
Case Else
'do nothing
End Select

If iColor = 9999 Then
'do nothing
Else
Target.Interior.ColorIndex = iColor
For i = 1 To 1 'or 3????
With Worksheets("Sheet" & i)
With .Range("a1:CZ800")
Set FoundCell = .Cells.Find(What:=Target.Value, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
'not found in that range
Else
FirstAddress = FoundCell.Address
Do
FoundCell.Interior.ColorIndex = iColor
Set FoundCell = .FindNext(after:=FoundCell)
If FoundCell.Address = FirstAddress Then
'found the first one again, get out
Exit Do
End If
Loop
End If
End With
End With
Next i
End If

End Sub

 

[JVANWORTH]

I resent it

No I didn't.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

 

[Dave Peterson]

It worked for me when I tested it.

Can you create a small workbook and test it there?

 

[JVANWORTH]

I have created a small work book several times. Here is the procedure I used
to create the small workbook:

Open excel work book

Delete worksheet "Sheet 2". Change worksheet "Sheet 3" into "Source. and
move "Source" to the Left of "Sheet 1"

Type the following into wrksht "Source" (no code in this sheet)
A B
1 Math 9
2 Math 10
3 Math 11
4 Math 12

Copy the code you supplied on 09/02/07 into the VBA of Sheet 1.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim iColor As Long
Dim cell As Range
Dim i As Long
Dim FoundCell As Range
Dim FirstAddress As String

'one cell at a time!
If Target.Cells.Count > 1 Then Exit Sub

If Intersect(Target, Range("A1:CZ800")) Is Nothing Then Exit Sub

iColor = 9999 'just an indicator

Select Case UCase(Target.Value)
Case "ENG 9", "MATH 9", "SCI 9"
iColor = 3
Case "ENG 10", "MATH 10", "SCI 10"
iColor = 4
Case "ENG 11", "MATH 11", "SCI 11"
iColor = 5
Case "ENG 12", "MATH 12", "SCI 12"
iColor = 6
Case Else
'do nothing
End Select

If iColor = 9999 Then
'do nothing
Else
Target.Interior.ColorIndex = iColor
For i = 1 To 1 'or 3????
With Worksheets("Sheet" & i)
With .Range("a1:CZ800")
Set FoundCell = .Cells.Find(What:=Target.Value, _
after:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If FoundCell Is Nothing Then
'not found in that range
Else
FirstAddress = FoundCell.Address
Do
FoundCell.Interior.ColorIndex = iColor
Set FoundCell = .FindNext(after:=FoundCell)
If FoundCell.Address = FirstAddress Then
'found the first one again, get out
Exit Do
End If
Loop
End If
End With
End With
Next i
End If

End Sub

I link A1 of "Sheet 1" to A1 of "Source". A1 of "Sheet 1" turns Red.

Then I link A2 of "Sheet 1" to A2 of "Source". A2 of "Sheet 1" turns Green.
Same goes for A3 and A4 (assigned colors flash each time)

Next I type 'Math 9' into cells A1, A2, A3 & A4 in "Source".

When I return to "Sheet 1", cell A1 is Red 'Math 9', cell A2 is Green 'Math
9', cell A3 is Blue 'Math 9', and cell A4 is Yellow 'Math 9'.

Now I view code, ctrl-g and type: application.enableevents = true then
hit enter.

When I return to "Sheet 1" still no change.

That is how I have been testing it!

Do you see anything I might be missing?

John

 

[Dave Peterson]

Source is the worksheet module that should get the code. That's where you do
the manual changes, right?

And if you look at the code, you'll see these lines:

For i = 1 To 1 'or 3????
With Worksheets("Sheet" & i)

That's the worksheets that are being changed because of the changes made to
Source.