动态条件格式（索引、匹配）

Question

找到了这段代码，它完成了我需要的“部分”。 我有多个条件 (20) 并希望根据查找设置字体、背景、图案颜色。

我需要： 在 sheet2 范围 A:A 上，如果值与颜色表上的 J:J 列匹配，则应用相应的填充/图案颜色/字体颜色。

我有： 在颜色表的“G”中填充颜色。 颜色表的“H”中的图案颜色。 颜色表“I”中的字体颜色。 颜色表“J”中的颜色代码。example

有人会这么好心并为我修改它以改变图案颜色，字体颜色就像改变背景一样吗？

尝试了几个小时，遗憾的是失败了。 我认为这与设置范围和 internal.pattern / colorindex 等有关。

除非你有比这更简单的方法？ 希望我说得通。炒了一点，对不起。

代码：

Sub SetColors()

    ' DataCells: The cells that's going to be checked against the color values
    Set DataCells = Range("A1:A15") ' Update this value according to your data cell range

    ' ColorValueCells: The cells that contain the values to be colored
    Set ColorValueCells = Sheets("Colors").Range("j2:j41") ' Update this value according to your color value + index range

    ' Loop through data cells
    For Each DataCell In DataCells

        ' Loop through color value cells
        For Each ColorValueCell In ColorValueCells

            ' Search for a match
            If DataCell.Value = ColorValueCell.Value Then

                ' If there is a match, find the color index
                Set ColorIndexCell = Sheets("Colors").Range("g" & ColorValueCell.Row)


                ' Set data cell's background color with the color index
                DataCell.Interior.ColorIndex = ColorIndexCell.Value


            End If
        Next
    Next
End Sub

Answer 1

您可以使用Find() 代替嵌套循环：

Sub SetColors()
    Dim DataCells As Range, ColorValueCells As Range
    Dim datacell As Range, f As Range

    Set DataCells = Range("A1:A15")
    Set ColorValueCells = Sheets("Colors").Range("J2:J41")

    For Each datacell In DataCells

        Set f = ColorValueCells.Find(datacell.Value, lookat:=xlWhole) '<< match the color
        If Not f Is Nothing Then
            'got a match: set the properties from this row
            With datacell
                .Interior.ColorIndex = Sheets("Colors").Cells(f.Row, "G").Value
                'etc for any other settings...
            End With
        End If
    Next
End Sub

编辑：与其将各种格式设置存储在与f 单元格相同的行中，不如考虑根据需要对每个单元格进行格式设置，然后将设置直接从f 复制到每个目标细胞。

例如

With datacell
    .Interior.ColorIndex = f.Interior.ColorIndex
    'etc for any other settings...
End With

Answer 2

填充、图案和字体

• Sheet2 是工作表的 CodeName。您可以在选项卡上重命名它。

• 列变量被声明为变量，以便能够使用 列号或列字母。

  Option Explicit
  
  Sub FillColors()
  
    Const cStrRange As String = "A1:A15"  ' Target Range Address
    Const cStrColor As String = "J2:J41"  ' ColorIndex Range Address
    Const cVntFill As Variant = "G"       ' Fill ColorIndex Column
    Const cVntPattern As Variant = "H"    ' Pattern ColorIndex Column
    Const cVntFont As Variant = "I"       ' Font ColorIndex Column
  
    Dim Datacells As Range                ' Target Range
    Dim ColorValueCells As Range          ' ColorIndex Range
    Dim DataCell As Range                 ' Target Range Current Cell
    Dim ColorValueCell As Range           ' ColorIndex Range Current Cell
    Dim ColorIndexCell As Range           ' ColorIndex Match Cell
  
    With Sheet2
      Set Datacells = .Range(cStrRange)
      Set ColorValueCells = .Range(cStrColor)
      For Each DataCell In Datacells
        For Each ColorValueCell In ColorValueCells
          If DataCell.Value = ColorValueCell.Value Then
            Set ColorIndexCell = .Cells(ColorValueCell.Row, cVntFill)
            DataCell.Interior.ColorIndex = ColorIndexCell.Value
            Set ColorIndexCell = .Cells(ColorValueCell.Row, cVntPattern)
            DataCell.Interior.PatternColorIndex = ColorIndexCell.Value
            Set ColorIndexCell = .Cells(ColorValueCell.Row, cVntFont)
            DataCell.Font.ColorIndex = ColorIndexCell.Value
          End If
        Next
      Next
    End With
  
    Set ColorIndexCell = Nothing
    Set ColorValueCell = Nothing
    Set DataCell = Nothing
    Set ColorValueCells = Nothing
    Set Datacells = Nothing
  
  End Sub