Excel 使用VBA进行条件格式设置，通过引用另一个单元格进行格式设置来动态设置范围的样式

这是我的问题

因此，应用于范围

K3:K10

，我有几个不同的条件格式规则，它们需要一个特定的文本字符串，由引用单元格的内容加上一个常量文本字符串组成。每个规则为特定的引用单元格和常量文本字符串（死或活）组合应用不同的颜色。例如，在该范围内，如果单元格包含单词“Dog”，然后是空格，然后是单词“Dead”，则其格式将为红色。列

D

和

E

中的图例显示了根据标准组合（动物和死/活）适用于每只动物的颜色。我想做的是，当特定规则为真时，能够使用列

C

中的下拉列表为动物选择颜色，并让CF更改范围

K3:K10

内任何单元格的格式，以匹配列

C

中相关行的格式/样式

因此，如果

K3

为“狗死”，则应用与单元格

D3

相同的格式，或者如果它为“狗活”，则应用与

E3

相同的格式。我不想让CF把任何含有“死狗”或“活狗”的细胞变成浅红色，因为狗的颜色可能不是红色。它可以是绿色，也可以是蓝色

所以，我想我想要使用VBA实现动态条件格式。有人能帮我开始吗

谢谢

---

安迪。

起点
在Sheet事件中：

Private Sub Worksheet_Change(ByVal Target As Range)
    ApplyCond Range("K" & Target.Row)
End Sub

在模块中：

Public Sub ApplyCond(xx As Range)
    If xx.Value = "" Then Exit Sub
    xx.FormatConditions.Delete
    xx.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:=xx.Value
    kk = Split(xx.Value)
    a = -1
    b = -1
    For i = LBound(kk) To UBound(kk)
        Select Case kk(i)
        Case "Dead": a = 4
        Case "Alive": a = 5
        Case Else
            For e = 3 To 9999
                If Range("B" & e).Value = "" Then Exit For
                If Range("B" & e).Value = kk(i) Then
                    b = e
                End If
            Next
        End Select
    Next

    ' Apply Format
    On Error Resume Next
    If (a > 0) And (b > 0) Then
        With xx.FormatConditions(1).Interior
            .PatternColorIndex = Cells(b, a).Interior.PatternColorIndex
            .Color = Cells(b, a).Interior.Color
            .TintAndShade = Cells(b, a).Interior.TintAndShade
            .Pattern = Cells(b, a).Interior.Pattern
            .PatternThemeColor = Cells(b, a).Interior.PatternThemeColor
            .ThemeColor = Cells(b, a).Interior.ThemeColor
            .PatternTintAndShade = Cells(b, a).Interior.PatternTintAndShade
        End With
        With xx.FormatConditions(1).Font
            .Bold = Cells(b, a).Font.Bold
            .Italic = Cells(b, a).Font.Italic
            .Underline = Cells(b, a).Font.Underline
            .Strikethrough = Cells(b, a).Font.Strikethrough
            .ThemeColor = Cells(b, a).Font.ThemeColor
            .TintAndShade = Cells(b, a).Font.TintAndShade
            .Color = Cells(b, a).Font.Color
            .TintAndShade = Cells(b, a).Font.TintAndShade
        End With
    End If
End Sub

您需要验证拆分公式。也许最好使用LCase函数或其他过滤器。
在我的函数中，我不使用列“C”