基于细胞文本的VBA填充颜色

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.

我正在尝试根据关键字填充2500行表格中的单元格。我需要10个关键字和3种不同的颜色。我想出了以下内容，但我得到“运行时错误'13'：类型不匹配”。我怕我不知道那是什么。

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!

谢谢！

5 个解决方案

#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

在结束之前。它将告诉您哪个单元格在编辑器的即时窗口上提示错误

#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.

然后，您可以为单元格是否包含“可用”设置规则，将单元格突出显示为绿色。您可以根据需要添加任意数量的规则。你甚至可以为整张纸做这件事，所以它永远不是一个有限的范围。

#3

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

正如@SJR建议的那样，单元格中可能存在错误。

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

#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

#5

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

除了其他人提到的主要解决方案外，还有另一个问题

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

我正在尝试用2500行表填充单元格

Your code works for the top 500 rows only

您的代码仅适用于前500行
Either redefine the main range from Range("a2:az500") to Range("a2:az2500")

从Range（“a2：az500”）到Range（“a2：az2500”）重新定义主范围
Or use the more dynamic UsedRange area
或者使用更动态的UsedRange区域

Version 1 is your code in a condensed format:

版本1是压缩格式的代码：

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):

如果所有关键字都在一列中，则版本2对于较大的数据集要快得多（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

#1