ExcelBanter

ExcelBanter (https://www.excelbanter.com/)
-   Excel Programming (https://www.excelbanter.com/excel-programming/)
-   -   Worksheet Change event on different ranges with data validation (https://www.excelbanter.com/excel-programming/425175-worksheet-change-event-different-ranges-data-validation.html)

Savalou Dave
Worksheet Change event on different ranges with data validation
 
I'm trying to color code cells based on the value of a drop down
list. I want to use a worksheet change event since I have more than
three response options. Trouble is I have more than one response
pattern so I want the change event to be conditional to the cell
range. I have a range for each response pattern and corresponding
color coding scheme as below. Thanks in advance!



Private Sub Worksheet_Change(ByVal Target As Range)

Dim vLetter As String
Dim vColor As Long
Dim v2Letter As String
Dim v2Color As String
Dim v3Letter As String
Dim v3Color As String

Dim cRange As Range
Dim cell As Range
Dim c2Range As Range
Dim c3Range As Range

Set cRange = Intersect(Range("D3:J17"), Range(Target(1).Address))
If cRange Is Nothing Then Exit Sub

For Each cell In Target
vLetter = UCase(Left(cell.Value & " ", 2))
vColor = 0
Select Case vLetter
Case "YE"
vColor = 4
Case "NO"
vColor = 3
Case "CO"
vColor = 4
Case "MO"
vColor = 6
Case "PA"
vColor = 45
Case "N/"
vColor = 2

End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = vColor
Application.EnableEvents = True
Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor


Set c2Range = Intersect(Range("D4,D16,E10"), Range(Target
(1).Address))
If c2Range Is Nothing Then Exit Sub
For Each cell In Target
v2Letter = Left(cell.Value & " ", 5)
v2Color = 0
Select Case v2Letter
Case "Month"
v2Color = 4

Case "Quart"
v2Color = 6

Case "Never"
v2Color = 3

Case "Biann"
v2Color = 6

Case "Annua"
v2Color = 45

Case "N/A"
v2Color = 2


End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = v2Color
Application.EnableEvents = True
Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor

Set c3Range = Intersect(Range("F7:J7"), Range(Target(1).Address))
If c3Range Is Nothing Then Exit Sub

For Each cell In Target
v3Letter = Left(cell.Value & " ", 3)

v3Color = 0
Select Case v3Letter

Case "abc"
v3Color = 6

Case "def"
v3Color = 3


Case "jkl"
v3Color = 45

Case "mno"
v3Color = 2

End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = v3Color
Application.EnableEvents = True
Next cell

End Sub

Per Jessen
Worksheet Change event on different ranges with data validation
 
Hi

The problem is that your code exit the macro if Target don't intersect with
the first test range and there are missing some end ifs.

Look at this:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim vLetter As String
Dim vColor As Long
Dim v2Letter As String
Dim v2Color As String
Dim v3Letter As String
Dim v3Color As String

Dim cRange As Range
Dim cell As Range
Dim c2Range As Range
Dim c3Range As Range

Application.EnableEvents = False

Set cRange = Intersect(Range("D3:J17"), Range(Target(1).Address))
If Not cRange Is Nothing Then
For Each cell In Target
vLetter = UCase(Left(cell.Value & " ", 2))
vColor = 0
Select Case vLetter
Case "YE"
vColor = 4
Case "NO"
vColor = 3
Case "CO"
vColor = 4
Case "MO"
vColor = 6
Case "PA"
vColor = 45
Case "N/"
vColor = 2
End Select
cell.Interior.ColorIndex = vColor
Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor
End If

Set c2Range = Intersect(Range("D4,D16,E10"), Range(Target(1).Address))
If Not c2Range Is Nothing Then
For Each cell In Target
v2Letter = Left(cell.Value & " ", 5)
v2Color = 0
Select Case v2Letter
Case "Month"
v2Color = 4
Case "Quart"
v2Color = 6
Case "Never"
v2Color = 3
Case "Biann"
v2Color = 6
Case "Annua"
v2Color = 45
Case "N/A"
v2Color = 2
End Select
cell.Interior.ColorIndex = v2Color
Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor
End If

Set c3Range = Intersect(Range("F7:J7"), Range(Target(1).Address))
If Not c3Range Is Nothing Then
For Each cell In Target
v3Letter = Left(cell.Value & " ", 3)
v3Color = 0
Select Case v3Letter
Case "abc"
v3Color = 6
Case "def"
v3Color = 3
Case "jkl"
v3Color = 45
Case "mno"
v3Color = 2
End Select
cell.Interior.ColorIndex = v3Color
Next cell
End If
Application.EnableEvents = True
End Sub

Regards,
Per

"Savalou Dave" skrev i meddelelsen
...
I'm trying to color code cells based on the value of a drop down
list. I want to use a worksheet change event since I have more than
three response options. Trouble is I have more than one response
pattern so I want the change event to be conditional to the cell
range. I have a range for each response pattern and corresponding
color coding scheme as below. Thanks in advance!



Private Sub Worksheet_Change(ByVal Target As Range)

Dim vLetter As String
Dim vColor As Long
Dim v2Letter As String
Dim v2Color As String
Dim v3Letter As String
Dim v3Color As String

Dim cRange As Range
Dim cell As Range
Dim c2Range As Range
Dim c3Range As Range

Set cRange = Intersect(Range("D3:J17"), Range(Target(1).Address))
If cRange Is Nothing Then Exit Sub

For Each cell In Target
vLetter = UCase(Left(cell.Value & " ", 2))
vColor = 0
Select Case vLetter
Case "YE"
vColor = 4
Case "NO"
vColor = 3
Case "CO"
vColor = 4
Case "MO"
vColor = 6
Case "PA"
vColor = 45
Case "N/"
vColor = 2

End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = vColor
Application.EnableEvents = True
Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor


Set c2Range = Intersect(Range("D4,D16,E10"), Range(Target
(1).Address))
If c2Range Is Nothing Then Exit Sub
For Each cell In Target
v2Letter = Left(cell.Value & " ", 5)
v2Color = 0
Select Case v2Letter
Case "Month"
v2Color = 4

Case "Quart"
v2Color = 6

Case "Never"
v2Color = 3

Case "Biann"
v2Color = 6

Case "Annua"
v2Color = 45

Case "N/A"
v2Color = 2


End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = v2Color
Application.EnableEvents = True
Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor

Set c3Range = Intersect(Range("F7:J7"), Range(Target(1).Address))
If c3Range Is Nothing Then Exit Sub

For Each cell In Target
v3Letter = Left(cell.Value & " ", 3)

v3Color = 0
Select Case v3Letter

Case "abc"
v3Color = 6

Case "def"
v3Color = 3


Case "jkl"
v3Color = 45

Case "mno"
v3Color = 2

End Select
Application.EnableEvents = False
cell.Interior.ColorIndex = v3Color
Application.EnableEvents = True
Next cell

End Sub


Savalou Dave
Worksheet Change event on different ranges with data validation
 
On Mar 6, 1:49*pm, "Per Jessen" wrote:
Hi

The problem is that your code exit the macro if Target don't intersect with
the first test range and there are missing some end ifs.

Look at this:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim vLetter As String
Dim vColor As Long
Dim v2Letter As String
Dim v2Color As String
Dim v3Letter As String
Dim v3Color As String

Dim cRange As Range
Dim cell As Range
Dim c2Range As Range
Dim c3Range As Range

Application.EnableEvents = False

Set cRange = Intersect(Range("D3:J17"), Range(Target(1).Address))
If Not cRange Is Nothing Then
* * For Each cell In Target
* * * * vLetter = UCase(Left(cell.Value & " ", 2))
* * * * vColor = 0
* * * * Select Case vLetter
* * * * * * Case "YE"
* * * * * * * * vColor = 4
* * * * * * Case "NO"
* * * * * * * * vColor = 3
* * * * * * Case "CO"
* * * * * * * * vColor = 4
* * * * * * Case "MO"
* * * * * * * * vColor = 6
* * * * * * Case "PA"
* * * * * * * * vColor = 45
* * * * * * Case "N/"
* * * * * * * * vColor = 2
* * * * End Select
* * * * cell.Interior.ColorIndex = vColor
* * Next cell
* * 'Target.Offset(0, 1).Interior.colorindex = vColor
End If

Set c2Range = Intersect(Range("D4,D16,E10"), Range(Target(1).Address))
If Not c2Range Is Nothing Then
* * For Each cell In Target
* * * * v2Letter = Left(cell.Value & " ", 5)
* * * * v2Color = 0
* * * * Select Case v2Letter
* * * * * * Case "Month"
* * * * * * * * v2Color = 4
* * * * * * Case "Quart"
* * * * * * * * v2Color = 6
* * * * * * Case "Never"
* * * * * * * * v2Color = 3
* * * * * * Case "Biann"
* * * * * * * * v2Color = 6
* * * * * * Case "Annua"
* * * * * * * * v2Color = 45
* * * * * * Case "N/A"
* * * * * * * * v2Color = 2
* * * * End Select
* * * * cell.Interior.ColorIndex = v2Color
* * Next cell
'Target.Offset(0, 1).Interior.colorindex = vColor
End If

Set c3Range = Intersect(Range("F7:J7"), Range(Target(1).Address))
If Not c3Range Is Nothing Then
* * For Each cell In Target
* * * * v3Letter = Left(cell.Value & " ", 3)
* * * * v3Color = 0
* * * * Select Case v3Letter
* * * * * * Case "abc"
* * * * * * * * v3Color = 6
* * * * * * Case "def"
* * * * * * * * v3Color = 3
* * * * * * Case "jkl"
* * * * * * * * v3Color = 45
* * * * * * Case "mno"
* * * * * * * * v3Color = 2
* * * * End Select
* * * * cell.Interior.ColorIndex = v3Color
* * Next cell
End If
Application.EnableEvents = True
End Sub

Regards,
Per

"Savalou Dave" skrev i ...



I'm trying to color code cells based on the value of a drop down
list. *I want to use a worksheet change event since I have more than
three response options. *Trouble is I have more than one response
pattern so I want the change event to be conditional to the cell
range. *I have a range for each response pattern and corresponding
color coding scheme as below. *Thanks in advance!

Private Sub Worksheet_Change(ByVal Target As Range)

Dim vLetter As String
Dim vColor As Long
Dim v2Letter As String
Dim v2Color As String
Dim v3Letter As String
Dim v3Color As String

Dim cRange As Range
Dim cell As Range
Dim c2Range As Range
Dim c3Range As Range

* Set cRange = Intersect(Range("D3:J17"), Range(Target(1).Address))
* If cRange Is Nothing Then Exit Sub

* For Each cell In Target
* * vLetter = UCase(Left(cell.Value & " ", 2))
* * vColor = 0
* * Select Case vLetter
* * * *Case "YE"
* * * * * *vColor = 4
* * * *Case "NO"
* * * * * *vColor = 3
* * * *Case "CO"
* * * * * *vColor = 4
* * * *Case "MO"
* * * * * *vColor = 6
* * * *Case "PA"
* * * * * *vColor = 45
* * * *Case "N/"
* * * * * *vColor = 2

* * End Select
* * Application.EnableEvents = False
* * cell.Interior.ColorIndex = vColor
* * Application.EnableEvents = True
* Next cell
* * 'Target.Offset(0, 1).Interior.colorindex = vColor

* Set c2Range = Intersect(Range("D4,D16,E10"), Range(Target
(1).Address))
* If c2Range Is Nothing Then Exit Sub
* For Each cell In Target
* * v2Letter = Left(cell.Value & " ", 5)
* * v2Color = 0
* * Select Case v2Letter
* * * *Case "Month"
* * * * * *v2Color = 4

* * * *Case "Quart"
* * * * * *v2Color = 6

* * * *Case "Never"
* * * * * *v2Color = 3

* * * *Case "Biann"
* * * * * *v2Color = 6

* * * *Case "Annua"
* * * * * *v2Color = 45

* * * *Case "N/A"
* * * * * *v2Color = 2

* * End Select
* * Application.EnableEvents = False
* * cell.Interior.ColorIndex = v2Color
* * Application.EnableEvents = True
* Next cell
* * 'Target.Offset(0, 1).Interior.colorindex = vColor

* Set c3Range = Intersect(Range("F7:J7"), Range(Target(1).Address))
* If c3Range Is Nothing Then Exit Sub

* For Each cell In Target
* * *v3Letter = Left(cell.Value & " ", 3)

* * v3Color = 0
* * Select Case v3Letter

* * * *Case "abc"
* * * * * *v3Color = 6

* * * *Case "def"
* * * * * *v3Color = 3

* * * *Case "jkl"
* * * * * *v3Color = 45

* * * *Case "mno"
* * * * * *v3Color = 2

* * End Select
* * Application.EnableEvents = False
* * cell.Interior.ColorIndex = v3Color
* * Application.EnableEvents = True
* Next cell

End Sub- Hide quoted text -

- Show quoted text -

Thanks Per! That's working great! All the best.


All times are GMT +1. The time now is 07:35 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com