Adding Colour

[VBA Noob]

Hi,

I'm looking to add colour to a row selection when a certain criteria is met. There is more than three criteria so the below Conditional formatting won't work on the test table also attached.

Order customer source £
4 bill a 6
4 bill d 5
5 bill a 7
5 bill b 4
5 bill c 3


Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF($C1=""a"",TRUE,FALSE)"
Selection.FormatConditions(1).Interior.ColorIndex = 36
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF($C1=""b"",TRUE,FALSE)"
Selection.FormatConditions(2).Interior.ColorIndex = 35
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=IF($C1=""f"",TRUE,FALSE)"
Selection.FormatConditions(3).Interior.ColorIndex = 40

So I've tried using a If and Do statement but I'm having trouble with it. Can anyone point me in the right direction

Sub Add_Colour()


Range("C2").Select
Application.ScreenUpdating = False

Do

If ActiveCell = "a" Then Call SelectActiveRow
With Selection
.ColorIndex = 36
End With
End If
If ActiveCell = "b" Then Call SelectActiveRow
End
With Selection
.ColorIndex = 35
End With
End If
If ActiveCell = "c" Then Call SelectActiveRow
With Selection
.ColorIndex = 34
End With
End If
If ActiveCell = "d" Then Call SelectActiveRow
With Selection
.ColorIndex = 37
End With
End If
ActiveCell.Offset(1, 0).Range("A1").Select
Loop Until IsEmpty(ActiveCell.Offset(0, 1))

Application.ScreenUpdating = True

End Sub

Sub SelectActiveRow()
If IsEmpty(ActiveCell) Then Exit Sub
' ignore error if activecell is in Column A
On Error Resume Next
If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
Range(LeftCell, RightCell).Select
End Sub

Thanks in advance

VBA Noob

[Ikaabod]

If I interpretted your code correctly this should work:

Sub Add_Colour()
Range("A2").Select
Application.ScreenUpdating = False

Do
ActiveCell.Offset(0, 2).Activate
If ActiveCell = "a" Then myColor = 36
If ActiveCell = "b" Then myColor = 35
If ActiveCell = "c" Then myColor = 34
If ActiveCell = "d" Then myColor = 37
If ActiveCell <> "a" And ActiveCell <> "b" And ActiveCell <> "c" And ActiveCell <> "d" Then
MsgBox "The ActiveCell does not equal any of the choices."
Exit Sub
End If

If IsEmpty(ActiveCell) Then Exit Sub
' ignore error if activecell is in Column A
On Error Resume Next
If IsEmpty(ActiveCell.Offset(0, -1)) Then Set LeftCell = ActiveCell Else Set LeftCell = ActiveCell.End(xlToLeft)
If IsEmpty(ActiveCell.Offset(0, 1)) Then Set RightCell = ActiveCell Else Set RightCell = ActiveCell.End(xlToRight)
Range(LeftCell, RightCell).Select

With Selection.Interior
.ColorIndex = myColor
End With

ActiveCell.Offset(1, 0).Range("A1").Select
Loop Until IsEmpty(ActiveCell)

Application.ScreenUpdating = True
End Sub

Hope that's what you needed.

-Ikaabod

[VBA Noob]

Thanks Ikaabod.

That worked.

Also got another solution now

Sub FillColors()
Dim c As Range
For Each c In Range("C1:C" & Cells(Rows.Count, 3).End(xlUp).Row)
Select Case c
Case "a"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 36
Case "b"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 35
Case "c"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 34
Case "d"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 37
Case "e"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 27
Case "f"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 40
Case "g"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 24
Case "h"
Range(c.Offset(0, -2), c.End(xlToRight)).Interior.ColorIndex = 46
End Select
Next c
End Sub

Danny