VBA Fill Color Based on Cell Text

Question

I'm trying to fill cells in a 2500 row sheet depending on keyword. There are 10 keywords and 3 different colours I need. I've come up with the following but I'm getting "Run-Time error '13': Type Mismatch". I'm afraid I don't know what that is.

Sub ColourChange()
    Dim cell As Range
    For Each cell In Range("a2:az500")
        If cell.Value = "Available" Then
            cell.Interior.Color = XlRgbColor.rgbLightGreen
        ElseIf cell.Value = "Deal" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Sold +Excl" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Sold Excl" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Holdback" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Pending" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Expired" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Sold CoX" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.Value = "Resell" Then
            cell.Interior.Color = XlRgbColor.rgbLightGreen
        ElseIf cell.Value = "Sold nonX" Then
            cell.Interior.Color = XlRgbColor.rgbBlue
        ElseIf cell.Value = "Sold NonX" Then
            cell.Interior.Color = XlRgbColor.rgbBlue
        End If
    Next
End Sub

Thanks!

J

Answer 1

Add in the line:

Else
debug.print cell.value & cell.address

before End If. It will tells you which cell prompts the error on the immediate window on your editor

Answer 2

Can I suggest conditional formatting? I believe it will be less complicated and will avoid any runtime errors.

If you select your range --> press the Home tab --> conditional formatting --> highlight cell rules --> text that contains

You can then set up rules for if a cell contains "available", highlight it the cell light green. You can add as many rules as you'd like. You can even do it for the whole sheet so it's never a finite range.

Answer 3

As @SJR suggested, there probably is an error in the cell.

Sub ColourChange()
    Dim cell As Range
    For Each cell In Range("a2:az500")
        If IsError(cell.value) Then
            cell.Interior.Color = XlRgbColor.rgbOrange
        ElseIf cell.value = "Available" Then
            cell.Interior.Color = XlRgbColor.rgbLightGreen
        ElseIf cell.value = "Deal" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Sold +Excl" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Sold Excl" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Holdback" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Pending" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Expired" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Sold CoX" Then
            cell.Interior.Color = XlRgbColor.rgbRed
        ElseIf cell.value = "Resell" Then
            cell.Interior.Color = XlRgbColor.rgbLightGreen
        ElseIf cell.value = "Sold nonX" Then
            cell.Interior.Color = XlRgbColor.rgbBlue
        ElseIf cell.value = "Sold NonX" Then
            cell.Interior.Color = XlRgbColor.rgbBlue
        End If
    Next
End Sub

Answer 4

This will solve you error problem

Sub ColourChange()
Dim cell As Range
For Each cell In Range("a2:az500")
 If Not iserror(cell.Value) Then
  If cell.Value = "Available" Then
    cell.Interior.Color = XlRgbColor.rgbLightGreen
  ElseIf cell.Value = "Deal" Then
    cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Sold +Excl" Then
   cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Sold Excl" Then
   cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Holdback" Then
   cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Pending" Then
   cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Expired" Then
   cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Sold CoX" Then
   cell.Interior.Color = XlRgbColor.rgbRed
  ElseIf cell.Value = "Resell" Then
   cell.Interior.Color = XlRgbColor.rgbLightGreen
  ElseIf cell.Value = "Sold nonX" Then
   cell.Interior.Color = XlRgbColor.rgbBlue
  ElseIf cell.Value = "Sold NonX" Then
   cell.Interior.Color = XlRgbColor.rgbBlue
  End If
 End If 'error check
Next
End Sub

Answer 5

Besides the main solution mentioned by others, there is another issue

I'm trying to fill cells in a 2500 row sheet

• Your code works for the top 500 rows only

• Either redefine the main range from Range("a2:az500") to Range("a2:az2500")

• Or use the more dynamic UsedRange area

---

Version 1 is your code in a condensed format:

Option Explicit

Public Sub ColourChange1()
    Dim itm As Range

    Application.ScreenUpdating = False
    Sheet1.UsedRange.Offset(1).Interior.ColorIndex = xlColorIndexNone

    For Each itm In Sheet1.UsedRange.Offset(1)
        If Not IsError(itm) Then
            With itm
                Select Case .Value2
                    Case "Available", "Resell"
                        .Interior.Color = XlRgbColor.rgbLightGreen
                    Case "Deal", "Sold +Excl", "Sold Excl", "Holdback", _
                         "Pending", "Expired", "Sold CoX"
                        .Interior.Color = XlRgbColor.rgbRed
                    Case "Sold nonX", "Sold NonX"
                        .Interior.Color = XlRgbColor.rgbBlue
                End Select
            End With
        End If
    Next
    Application.ScreenUpdating = True
End Sub

---

Version 2 is much faster for larger data sets, if all your keywords are in one column (A):

Public Sub ColourChange2()
    Dim mapping As Object, itm As Variant

    Set mapping = CreateObject("Scripting.Dictionary")

    mapping(XlRgbColor.rgbLightGreen) = Array("Available", "Resell")

    mapping(XlRgbColor.rgbRed) = Array("Deal", "Sold +Excl", "Sold Excl", _
                                       "Holdback", "Pending", "Expired", "Sold CoX")

    mapping(XlRgbColor.rgbBlue) = Array("Sold nonX", "Sold NonX")

    Application.ScreenUpdating = False
    Sheet1.AutoFilterMode = False
    With Sheet1.UsedRange
        .Interior.ColorIndex = xlColorIndexNone
        For Each itm In mapping
            .AutoFilter Field:=1, Criteria1:=mapping(itm), Operator:=xlFilterValues
            .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Interior.Color = itm
        Next
        .AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub