Solved: Adding conditional formatting VBA

[georgedaws]

Hi,

Courtesy of "mdmackillop" he produced some fine code which works flawlessly.

[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 3
Call Macro1(Target)
Case 16
Call Macro2(Target)
Case Else
Call Macro3(Target)
End Select

End Sub

Private Sub Macro1(ByVal Target As Range)
Dim c As Range, i As Long
On Error Resume Next
Set c = Intersect(Target, Columns(3))
If c Is Nothing Then Exit Sub
If IsEmpty(c.Offset(-1, 0)) Or Not IsEmpty(c.Offset(1, 0)) Then Exit Sub
i = c.Row
Application.EnableEvents = False
Range("A" & i - 1 & ":B" & i - 1).Copy Range("A" & i & ":B" & i)
Application.EnableEvents = True
On Error Goto 0
End Sub


Private Sub Macro2(ByVal Target As Range)
Dim c As Range, i As Long
On Error Resume Next
Set c = Intersect(Target, Columns(16))
If c Is Nothing Then Exit Sub
If IsEmpty(c.Offset(-1, 0)) Or Not IsEmpty(c.Offset(1, 0)) Then Exit Sub
i = c.Row
Application.EnableEvents = False
Range("Q" & i - 1).Copy Range("Q" & i) '<===Check this line
Application.EnableEvents = True
On Error Goto 0
End Sub

Private Sub Macro3(ByVal Target As Range)
Const sWSPWD As String = ""
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Me.Range("F3:F10000")) Is Nothing Then
Me.Unprotect ""
If Target.Offset(, 2) = "" Then Target.Offset(, 2) = Date
Me.Protect ""
ElseIf Not Intersect(Target, Me.Range("L3:L10000")) Is Nothing Then
ActiveSheet.Unprotect ""
If Target.Offset(, 1) = "" Then Target.Offset(, 1) = Date
ActiveSheet.Protect ""
ElseIf Not Intersect(Target, Me.Range("O3:O10000")) Is Nothing Then
ActiveSheet.Unprotect ""
If Target.Offset(, 1) = "" Then Target.Offset(, 1) = Date
ActiveSheet.Protect ""
ElseIf Not Intersect(Target, Me.Range("T3:T10000")) Is Nothing Then
ActiveSheet.Unprotect ""
If Target.Offset(, 1) = "" Then Target.Offset(, 1) = Date
ActiveSheet.Protect ""
End If
End Sub [/VBA]

I can see what happens and how the macros are called. However, I want to add conditional formatting with four criteria to column "Q". I have code but I cannot see how I can add to the existing macro list as they allude to columns and this code below alludes to a range

[VBA]Private Sub Worksheet_Change(ByVal Target As Range)

Dim icolor As Integer



If Not Intersect(Target, Range("A1:A10")) is Nothing Then

Select Case Target

Case 1 To 6

icolor = 4

Case 7 To 10

icolor = 45

Case 11 To 1000000000000

icolor = 3

Case Else

'Whatever

End Select



Target.Interior.ColorIndex = icolor

End If



End Sub[/VBA]

Basically a red, amber, green, or no fill. With no number at all, no cell colour change, 0-6 green 7-10 amber 11+ red.

Any guidance much appreciated.

Thank you.

[georgedaws]

Sorry, that code for the conditional formatting is meant to be for column "Q" range, not "A"

Cheers

[georgedaws]

Anyone with any thoughts on how I can join the two, or any different conditional formatting code that I could use to make a "fourth macro that will call a "case"

Thanks

[mdmackillop]

[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 1
Call Macro4(Target)
Case 3
Call Macro1(Target)
Case 16
Call Macro2(Target)
Case Else
Call Macro3(Target)
End Select
End Sub

Private Sub Macro4(ByVal Target As Range)
Dim icolor As Integer
If Not Intersect(Target, Range("A1:A10")) Is Nothing Then
Select Case Target.Offset(, 22)
Case 1 To 6
icolor = 4
Case 7 To 10
icolor = 45
Case 11 To 1000000000000#
icolor = 3
Case Else
'Whatever
End Select
Target.Offset(, 22).Interior.ColorIndex = icolor
End If
End Sub[/VBA]

[georgedaws]

Mr. mdmackillop, I thank you again. I really wanted to have a go at this myself after the last time you helped me, but I hope you can appreciate where I was stuck.

Thank you again.

[georgedaws]

If you are there mdmackillop, I could really use your help again.

As you noticed I was meant to have put column "Q" as my target which would have meant no offset which is fine.

The problem is once a number (which is produced by the formula) is put automatically into column "Q" (from the offset macro column "P" or "16") The conditional formatting has no effect. If I overide and manually put a number into column "Q" it works.

Here is the code as it stands

[VBA]Private Sub Worksheet_Change(ByVal Target As Range)
Select Case Target.Column
Case 17
Call Macro4(Target)
Case 3
Call Macro1(Target)
Case 16
Call Macro2(Target)
Case Else
Call Macro3(Target)
End Select
End Sub

Private Sub Macro4(ByVal Target As Range)
Dim icolor As Integer
If Not Intersect(Target, Range("Q3:Q60000")) Is Nothing Then
Select Case Target.Offset(, 0)
Case 0 To 6
icolor = 4
Case 7 To 10
icolor = 45
Case 11 To 1000000000000#
icolor = 3
Case Else
'Whatever
End Select
Target.Offset(, 0).Interior.ColorIndex = icolor
End If
End Sub
Private Sub Macro1(ByVal Target As Range)
Dim c As Range, i As Long
On Error Resume Next
Set c = Intersect(Target, Columns(3))
If c Is Nothing Then Exit Sub
If IsEmpty(c.Offset(-1, 0)) Or Not IsEmpty(c.Offset(1, 0)) Then Exit Sub
i = c.Row
Application.EnableEvents = False
Range("A" & i - 1 & ":B" & i - 1).Copy Range("A" & i & ":B" & i)
Application.EnableEvents = True
On Error GoTo 0
End Sub


Private Sub Macro2(ByVal Target As Range)
Dim c As Range, i As Long
On Error Resume Next
Set c = Intersect(Target, Columns(16))
If c Is Nothing Then Exit Sub
If IsEmpty(c.Offset(-1, 0)) Or Not IsEmpty(c.Offset(1, 0)) Then Exit Sub
i = c.Row
Application.EnableEvents = False
Range("Q" & i - 1).Copy Range("Q" & i) '<===Check this line
Application.EnableEvents = True
On Error GoTo 0
End Sub

Private Sub Macro3(ByVal Target As Range)
Const sWSPWD As String = ""
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Me.Range("F3:F60000")) Is Nothing Then
Me.Unprotect ""
If Target.Offset(, 2) = "" Then Target.Offset(, 2) = Date
Me.Protect ""
ElseIf Not Intersect(Target, Me.Range("L3:L60000")) Is Nothing Then
ActiveSheet.Unprotect ""
If Target.Offset(, 1) = "" Then Target.Offset(, 1) = Date
ActiveSheet.Protect ""
ElseIf Not Intersect(Target, Me.Range("O3:O60000")) Is Nothing Then
ActiveSheet.Unprotect ""
If Target.Offset(, 1) = "" Then Target.Offset(, 1) = Date
ActiveSheet.Protect ""
ElseIf Not Intersect(Target, Me.Range("T3:T60000")) Is Nothing Then
ActiveSheet.Unprotect ""
If Target.Offset(, 1) = "" Then Target.Offset(, 1) = Date
ActiveSheet.Protect ""
End If
End Sub
[/VBA]

Can you help please? (or anyone??)

It is frying my brain!

Thank you.

[mdmackillop]

[VBA]
Private Sub Worksheet_Calculate()
Macro4A
End Sub

Private Sub Macro4A()
Dim icolor As Integer, Cel As Range
For Each Cel In Range("Q3:Q60000").SpecialCells(xlCellTypeFormulas)
Select Case Cel
Case 0 To 6
icolor = 4
Case 7 To 10
icolor = 45
Case 11 To 1000000000000#
icolor = 3
Case Else
'Whatever
End Select
Cel.Interior.ColorIndex = icolor
Next
End Sub

[/VBA]

[georgedaws]

Thank you again mcmackillop. The code started working, then I got a runtime 1004 error alluding to password protection so I put

[VBA]ActiveSheet.Unprotect Password:=""[/VBA] after [VBA]Dim icolor As Integer, Cel As Range [/VBA]

and [VBA]ActiveSheet.Protect Password:=""[/VBA] after [VBA]cell.Interior.ColorIndex = icolor[/VBA]

Now when I run it I get another runtime error 1004 application defined or object defined error. Debug highlights
[VBA]cell.Interior.ColorIndex = icolor[/VBA]

Am I making a right mess of this? Could you tell me how to put in the last condition I need to revert the cell back to its original colour if data is removed please. I have only found some code which is written completely different to yours and with, for example [VBA]Case Empty, CI = xlColorIndexNone[/VBA] which isn't icolor.

Thank you for all your time. If you lived near me I'd buy you a pint!

Thanks again

[mdmackillop]

Can you post your whole code. It's easier to comprehend.

[georgedaws]

Hi mdmackillop,

Sorry for delayed reply. Been on a bit of a DIY mission last few days.

Just to let you know that I sort of solved it!

Here is my code

[VBA]Private Sub Macro4A()
Dim CI As Long, Cel As Range
Const sWSPWD As String = ""
ActiveSheet.Unprotect ""
For Each Cel In Range("Q3:Q60000").SpecialCells(xlCellTypeFormulas)
Select Case Cel
Case 0 To 6: CI = 4
Case 7 To 10: CI = 45
Case 10 To 100: CI = 3
Case Empty, CI = 43
End Select
Cel.Interior.ColorIndex = CI
Next
ActiveSheet.Protect ""
End Sub[/VBA]

It doesn't revert the cells back to their original colour but it refills with their original colour on "case empty"

Thank you for all your help and patience with me. You've been a Godsend!


Thanks