PDA

View Full Version : [SOLVED] Select Case Conditional Formatting VBA



Nick72310
04-18-2016, 12:31 PM
I am trying to simplify my conditional formatting (CF) code by using select case. However, I cannot seem to get the code to run through anything other than case "".
The reason I am trying to code the CF is because when a person copy and paste data, the CF gets all messed up.

My code is shown below. I have the CF code in a separate macro, called "CF", and it gets called in worksheet_change, which also includes auto capitalizing (that works fine).


Private Sub worksheet_change(ByVal Target As Range)
On Error Resume Next
'Default Cells and AUTOCAPS
Dim RngToCheckForNonFormulae As Range, RngToCheckForUserInput As Range, cll As Range
On Error GoTo GracefulExit
'AUTO CAPS and CF

With ActiveCell
r = .Row
c = .Column
r = r - 1
End With

Set RngToCheckForUserInput = Intersect(Target, Range(Cells(4, 2), Cells(Rows.Count, 2)))
If Not RngToCheckForUserInput Is Nothing Then
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
For Each cll In RngToCheckForUserInput.Cells
If Not cll.HasFormula And Len(cll.Value) > 0 Then cll.Value = UCase(cll.Value)
Next cll

Cells(r, c).Select
'------------------ Conditional Formatting Code gets called here --------------------------
Call CF
'------------------------------------------------------------------------------------------
Cells(r + 1, c).Select

End If
GracefulExit:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub


Sub CF()
Selection.FormatConditions.Delete
Dim rr, gg, bb

With ActiveCell
r = .Row
c = .Column
r = r - 1
End With

Select Case Sheets("Hide2").Cells(r, c)
Case False
rr = 0
gg = 0
bb = 0
GoTo Color_Code
Case "inactive"
rr = 0
gg = 0
bb = 0
GoTo Color_Code
Case "rfq"
rr = 112
gg = 48
bb = 160
GoTo Color_Code
Case "phase-out"
rr = 51
gg = 63
bb = 79
GoTo Color_Code
Case "engineer"
rr = 0
gg = 176
bb = 80
GoTo Color_Code
Case "design"
rr = 255
gg = 103
bb = 0
GoTo Color_Code
Case "obsolete"
rr = 255
gg = 51
bb = 0
GoTo Color_Code
Case "prototype"
rr = 0
gg = 133
bb = 192
GoTo Color_Code
Case ""
Exit Sub
End Select

Color_Code:
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=Hide2!B" & Selection.Row & "=" & Sheets("Hide2").Cells(r, c) & ""
'"=""inactive"""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriori ty
With Selection.FormatConditions(1).Font
'Black
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0

'White
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Borders(xlLeft)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.FormatConditions(1).Borders(xlRight)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.FormatConditions(1).Borders(xlTop)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.FormatConditions(1)
.Interior.Color = RGB(rr, gg, bb)
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub

Bob Phillips
04-19-2016, 05:17 AM
Can you post the workbook?

Nick72310
04-19-2016, 06:54 AM
Here it the file.

15962

I have another posted forum regarding this same spreadsheet (different question), so that will be all the other stuff you see in the file. Feel free to take a look at that if you wish. But at the moment, I am more concerned with the conditional formatting question.

http://www.vbaexpress.com/forum/showthread.php?55738-Match-a-string-with-a-string-that-includes-a-wildcard-%28*%29-excel

Bob Phillips
04-19-2016, 07:24 AM
Private Sub worksheet_change(ByVal Target As Range)
On Error Resume Next
'Default Cells and AUTOCAPS
Dim RngToCheckForNonFormulae As Range, RngToCheckForUserInput As Range, cll As Range
Dim r As Long, c As Long

On Error GoTo GracefulExit

If Target.Cells.Count = 1 Then

Set RngToCheckForUserInput = Intersect(Target, Range(Cells(4, 2), Cells(Rows.Count, 2)))
If Not RngToCheckForUserInput Is Nothing Then

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

r = Target.Row - 1
c = Target.Column

For Each cll In RngToCheckForUserInput.Cells

If Not cll.HasFormula And Len(cll.Value) > 0 Then cll.Value = UCase(cll.Value)
Next cll

Call CF(Target)
Cells(r + 1, c).Select
End If
End If

GracefulExit:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub


Sub CF(ByRef Target As Range)
Target.FormatConditions.Delete
Dim rr, gg, bb

Select Case LCase(Sheets("Hide2").Cells(Target.Row, Target.Column).Value)
Case False
rr = 0
gg = 0
bb = 0
Case "inactive"
rr = 0
gg = 0
bb = 0
Case "rfq"
rr = 112
gg = 48
bb = 160
Case "phase-out"
rr = 51
gg = 63
bb = 79
Case "engineer"
rr = 0
gg = 176
bb = 80
Case "design"
rr = 255
gg = 103
bb = 0
Case "obsolete"
rr = 255
gg = 51
bb = 0
Case "prototype"
rr = 0
gg = 133
bb = 192
Case ""
Exit Sub
End Select

Color_Code:
With Target

.FormatConditions.Add Type:=xlExpression, Formula1:="=Hide2!B" & .Row & "=""" & Sheets("Hide2").Cells(Target.Row, Target.Column) & """"
'"=""inactive"""
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Font

'Black
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0

'White
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With

With .FormatConditions(1).Borders(xlLeft)

.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With

With .FormatConditions(1).Borders(xlRight)

.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With

With .FormatConditions(1).Borders(xlTop)

.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With .FormatConditions(1).Borders(xlBottom)

.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With

With .FormatConditions(1)
.Interior.Color = RGB(rr, gg, bb)
End With

.FormatConditions(1).StopIfTrue = False
End With
End Sub

Nick72310
04-19-2016, 08:04 AM
Works great!!! I tested all the cases. Thank you!

Nick72310
04-19-2016, 08:27 AM
Actually, I have one last question. How can I also add: If it's a duplicate, RGB(255, 255, 0)? That would need to go on every condition.

Bob Phillips
04-19-2016, 11:52 AM
What designates a duplicate? And does that take precedence over the other test?

Nick72310
04-19-2016, 12:19 PM
It will be considered a duplicate if any of the items in the range are the same name. [Set RngToCheckForUserInput = Intersect(Target, Range(Cells(4, 2), Cells(Rows.Count, 2)))]
Yes, duplicates are at the top of the hierarchy. It needs to be known before the other rules.

snb
04-20-2016, 12:08 AM
Alternative for Select Case:



y = Choose(InStr("rfphendeobpr", Left(LCase(target), 2)) \ 2 + 1, 0, RGB(112, 48, 180), RGB(51, 63, 79), RGB(0, 176, 80), RGB(255, 103, 0), RGB(255, 51, 0), RGB(0, 133, 192))