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").Selec
Application.ScreenUpdating = Fals

D
ActiveCell.Offset(0, 2).Activat
If ActiveCell = "a" Then myColor = 3
If ActiveCell = "b" Then myColor = 3
If ActiveCell = "c" Then myColor = 3
If ActiveCell = "d" Then myColor = 3
If ActiveCell <> "a" And ActiveCell <> "b" And ActiveCell <> "c" An
ActiveCell <> "d" The
MsgBox "The ActiveCell does not equal any of the choices.
Exit Su
End I

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

With Selection.Interio
.ColorIndex = myColo
End Wit

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

Application.ScreenUpdating = Tru
End Su

Hope that's what you needed

-Ikaabo

 

[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