PDA

View Full Version : Solved: Adding conditional formatting VBA



georgedaws
03-23-2011, 05:00 AM
Hi,

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

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

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

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

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
03-23-2011, 06:55 AM
Sorry, that code for the conditional formatting is meant to be for column "Q" range, not "A"

Cheers

georgedaws
03-23-2011, 11:12 AM
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
03-23-2011, 03:09 PM
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

georgedaws
03-23-2011, 03:56 PM
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
03-24-2011, 05:20 AM
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

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


Can you help please? (or anyone??)

It is frying my brain!

Thank you.

mdmackillop
03-24-2011, 10:22 AM
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

georgedaws
03-24-2011, 02:02 PM
Thank you again mcmackillop. The code started working, then I got a runtime 1004 error alluding to password protection so I put

ActiveSheet.Unprotect Password:="" after Dim icolor As Integer, Cel As Range

and ActiveSheet.Protect Password:="" after cell.Interior.ColorIndex = icolor

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

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 Case Empty, CI = xlColorIndexNone which isn't icolor.

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

Thanks again

mdmackillop
03-24-2011, 04:17 PM
Can you post your whole code. It's easier to comprehend.

georgedaws
03-28-2011, 06:02 AM
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

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

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