Row Color VBA Code

[JeffD]

I have a code to change row colour based on number of days open in column E.
If 1 - 2 days it turns green, 3 -5 yellow, 6 to 50 red.
I now need code to change the row color based on colunm a Text. If CQMP change color as above.
If CQWR change color 1 to 15 Green, 16 to 25 yellow, 25 to 50 red.
Is this possible?


Sub Update_Row_Colors_Rev1()
''YOUR CODE "tstc"
Sheet1.Unprotect Password:="tstc"
Dim LRow As Integer
Dim LCell As String
Dim ICell As String

Dim LColorCells As String
'Start at row 8
LRow = 8

'Update row colors for the first 500 rows
While LRow < 100
LCell = "E" & LRow
ICell = "A" & LRow
'Color will changed in columns A to AR
LColorCells = "A" & LRow & ":" & "AR" & LRow

Select Case Left(Range(LCell)(ICell).Value, 6)


'Set row color to light green
Case "0", "1", "2"
Case "CQMP"
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 35
Range(LColorCells).Interior.Pattern = xlSolid
Selection.Font.Bold = True
Selection.Font.Color = RGB(0, 0, 0)
Else
Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12", "13", "14", "15"
Case "CQWR"
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 35
Range(LColorCells).Interior.Pattern = xlSolid
Selection.Font.Bold = True
Selection.Font.Color = RGB(0, 0, 0)

'Set row color to light yellow
Case "3", "4", "5"
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 6
Range(LColorCells).Interior.Pattern = xlSolid
Selection.Font.Bold = True
Selection.Font.Color = RGB(0, 0, 0)



'Set row color to light red
Case "6", "7", "8", "9", "10", "11", "12", "13", "14", "15", "16", "17", "18", "19", "20", "21", "22", "23", "24", "25", "26", "27", "28", "29", "30", "31", "32", "33", "34", "35", ";36", "37", "38", "39", "40", "41", ";42", "43", "44", "45", "46", "47", "48", "49", "50"
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 3
Range(LColorCells).Interior.Pattern = xlSolid
Selection.Font.Bold = True
Selection.Font.Color = RGB(255, 255, 255)


'Default all other rows to no color
Case Else
Rows(LRow & ":" & LRow).Select
Range(LColorCells).Interior.ColorIndex = 0
Selection.Font.Bold = False
Selection.Font.Color = RGB(0, 0, 0)

End Select

LRow = LRow + 1
Wend

Range("A1").Select
ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Select
Sheet1.Protect Password:="tstc", DrawingObjects:=False, _
contents:=True, Scenarios:=True, _
userinterfaceonly:=True, AllowFormattingCells:=True, AllowInsertingHyperlinks:=True, AllowFormattingRows:=True, AllowFormattingColumns:=True_

Sheet1.EnableAutoFilter = True

End Sub

 

[MrKowz]

Might I ask, why use VBA? Why not Conditional Formatting?

 

[JeffD]

I already have 2 conditions used up and I'm working on excel 2003. The company I work for will be upgrading this year to 2010.

 

[MrKowz]

Ahh, I think I see what you need now. Let me reprogram this and clean it up, I'll have some working code for you momentarily.

 

[MrKowz]

Try this out. Since you have such a broad range of numbers to check, a Select Case statement gets too messy. Sometimes it is easier and more effecient to just use nested IFs.

Public Sub Update_Row_Colors_Rev2()
Dim i   As Long, _
    LR  As Long
    
Application.ScreenUpdating = False
LR = Range("E" & rows.Count).End(xlUp).Row
For i = 8 To LR
    If Range("A" & i).Value = "CQMP" Then
        If Range("E" & i).Value <= 2 Then
            rows(i).Interior.ColorIndex = 35
        ElseIf Range("E" & i).Value <= 5 Then
            rows(i).Interior.ColorIndex = 6
        ElseIf Range("E" & i).Value <= 50 Then
            rows(i).Interior.ColorIndex = 3
        End If
    ElseIf Range("A" & i).Value = "CQWR" Then
        If Range("E" & i).Value <= 15 Then
            rows(i).Interior.ColorIndex = 35
        ElseIf Range("E" & i).Value <= 25 Then
            rows(i).Interior.ColorIndex = 6
        ElseIf Range("E" & i).Value <= 50 Then
            rows(i).Interior.ColorIndex = 3
        End If
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[JeffD]

This is very close. It didnt work because I have CQMP#### and CQWR####. I'm assuming it's not reading just the first 4 text vs the 4 numbers.

If there is no rule to that I can have it sort by Column H and look for
Data, HTR, F.Y.I, or R.F.I. and change to the first set of color settings.

I also need it to change the font to Black/Bold for green and yellow and White/Bold for Red.

Thank you,

 

[MrKowz]

I'm not sure I understand what you meant in your second paragraph about "if there is no rule to that..." Can you please elaborate?

However, to fix the initial problems, try:

Public Sub Update_Row_Colors_Rev2()
Dim i   As Long, _
    LR  As Long
    
Application.ScreenUpdating = False
LR = Range("E" & rows.Count).End(xlUp).Row
For i = 8 To LR
    If Left(Range("A" & i).Value, 4) = "CQMP" Then
        If Range("E" & i).Value <= 2 Then
            With rows(i)
                .Interior.ColorIndex = 35
                .Font.Bold = True
                .Font.ColorIndex = 1
            End With
        ElseIf Range("E" & i).Value <= 5 Then
            With rows(i)
                .Interior.ColorIndex = 6
                .Font.Bold = True
                .Font.ColorIndex = 1
            End With
        ElseIf Range("E" & i).Value <= 50 Then
            With rows(i)
                .Interior.ColorIndex = 3
                .Font.Bold = True
                .Font.ColorIndex = 2
            End With
        End If
    ElseIf Left(Range("A" & i).Value, 4) = "CQWR" Then
        If Range("E" & i).Value <= 15 Then
            With rows(i)
                .Interior.ColorIndex = 35
                .Font.Bold = True
                .Font.ColorIndex = 1
            End With
        ElseIf Range("E" & i).Value <= 25 Then
            With rows(i)
                .Interior.ColorIndex = 6
                .Font.Bold = True
                .Font.ColorIndex = 1
            End With
        ElseIf Range("E" & i).Value <= 50 Then
            With rows(i)
                .Interior.ColorIndex = 3
                .Font.Bold = True
                .Font.ColorIndex = 2
            End With
        End If
    Else
        With rows(i)
            .Interior.ColorIndex = xlNone
            .Font.Bold = False
            .Font.ColorIndex = 1
        End With
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[JeffD]

This works fine! Column A will have CQMP123456 or CQWR123456 and I wasnt sure if it would read just the first 4 text to ensure the macro works.
I just tried and it worked fine. Thank you.