vba - 特定单元格值决定列颜色 Excel

Question

下面的代码有效，因此如果用户在分数部分输入 1-5 之间的数值，特定列/列组将改变颜色。如果分数不是 1、2、3、4 或 5 以外的任何数字，则列上不会发生任何填充。

假设用户为问题 2 输入值 3，“二”、“三”和“五”列将以黄色突出显示。

现在，如果用户为问题一输入值 1，“一”、“二”和“三”列将以红色突出显示。 “五”列仍将保持黄色，但“二”和“三”(因为分组与问题重叠)变为红色，因为这是最近的事件。

我似乎无法找到一种方法来使分数决定当前突出显示的单元格是否更改为不同的颜色。我希望这样，如果用户为问题 2 输入值 3，则“二”、“三”和“五”列将以黄色突出显示，但如果他们随后为问题一输入值 1 ，“一”列将以红色突出显示，“二”和“三”应保持黄色，因为分数 3 高于 1。

问题一按列分组:一、二、三

问题二按列分组:二、三、五

问题三按列分组:三、四

问题四按列分组:三、四

问题五按列分组:一、二、三

得分 1 显示:红色

得分 2 显示:橙色

得分 3 显示:黄色

分数 4 显示:浅绿色

得分 5 显示:深绿色

Private Sub CheckBox1_Click()

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D19")) Is Nothing Then
        Select Case Range("D19").Value
            Case 1
                Range("L3:N28").Interior.ColorIndex = 3
            Case 2
                Range("L3:N28").Interior.ColorIndex = 45
            Case 3
                Range("L3:N28").Interior.ColorIndex = 6
            Case 4
                Range("L3:N28").Interior.ColorIndex = 4
            Case 5
                Range("L3:N28").Interior.ColorIndex = 50
            Case Else
            Range("L3:N28").Interior.ColorIndex = 0
        End Select
    End If

    If Not Intersect(Target, Range("D20")) Is Nothing Then
        Select Case Range("D20").Value
            Case 1
                Range("M3:N28,P3:P28").Interior.ColorIndex = 3
            Case 2
                Range("M3:N28,P3:P28").Interior.ColorIndex = 45
            Case 3
                Range("M3:N28,P3:P28").Interior.ColorIndex = 6
            Case 4
                Range("M3:N28,P3:P28").Interior.ColorIndex = 4
            Case 5
                Range("M3:N28,P3:P28").Interior.ColorIndex = 50
            Case Else
            Range("M3:N28,P3:P28").Interior.ColorIndex = 0
        End Select
    End If

    If Not Intersect(Target, Range("D21")) Is Nothing Then
        Select Case Range("D21").Value
            Case 1
                Range("N3:O28").Interior.ColorIndex = 3
            Case 2
                Range("N3:O28").Interior.ColorIndex = 45
            Case 3
                Range("N3:O28").Interior.ColorIndex = 6
            Case 4
                Range("N3:O28").Interior.ColorIndex = 4
            Case 5
                Range("N3:O28").Interior.ColorIndex = 50
            Case Else
            Range("N3:O28").Interior.ColorIndex = 0
        End Select
    End If

    If Not Intersect(Target, Range("D22")) Is Nothing Then
        Select Case Range("D22").Value
            Case 1
                Range("N3:O28").Interior.ColorIndex = 3
            Case 2
                Range("N3:O28").Interior.ColorIndex = 45
            Case 3
                Range("N3:O28").Interior.ColorIndex = 6
            Case 4
                Range("N3:O28").Interior.ColorIndex = 4
            Case 5
                Range("N3:O28").Interior.ColorIndex = 50
            Case Else
            Range("N3:O28").Interior.ColorIndex = 0
        End Select
    End If

    If Not Intersect(Target, Range("D23")) Is Nothing Then
        Select Case Range("D23").Value
            Case 1
                Range("L3:N28").Interior.ColorIndex = 3
            Case 2
                Range("L3:N28").Interior.ColorIndex = 45
            Case 3
                Range("L3:N28").Interior.ColorIndex = 6
            Case 4
                Range("L3:N28").Interior.ColorIndex = 4
            Case 5
                Range("L3:N28").Interior.ColorIndex = 50
            Case Else
            Range("L3:N28").Interior.ColorIndex = 0
        End Select
    End If
End Sub

我希望我能正确地解释自己。任何帮助，谢谢。

Answer 1

下面的代码比较所有可能的答案组合，无论其顺序如何

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    If Target.Cells.CountLarge > 1 Then Exit Sub

    Const U1 = 19    'User input row 1
    Const U2 = 20
    Const U3 = 21
    Const U4 = 22
    Const U5 = 23
    Const D = 4      'User input column

    Dim r As Long, v As Long, fnd As Range
    r = Target.Row
    v = Val(Target.Value2)

    With Target.Parent

        Set fnd = .UsedRange.Find("One")    'find first question
        If Target.Column <> D Or r < U1 Or r > U5 Or v > 5 Or fnd Is Nothing Then Exit Sub

        Dim fr As Long, lr As Long, fc As Long
        fr = fnd.Row + 1                'first used row
        lr = .UsedRange.Rows.Count      'last used row
        fc = fnd.Column                 'last used column

        Dim a1 As Long, a2 As Long, a3 As Long, a4 As Long, a5 As Long
        a1 = Val(.Cells(U1, D).Value2)  'answer 1
        a2 = Val(.Cells(U2, D).Value2)
        a3 = Val(.Cells(U3, D).Value2)
        a4 = Val(.Cells(U4, D).Value2)
        a5 = Val(.Cells(U5, D).Value2)

        Dim c1 As Range, c2 As Range, c3 As Range, c4 As Range, c5 As Range
        Set c1 = .Range(.Cells(fr, fc + 0), .Cells(lr, fc + 0)) 'column 1
        Set c2 = .Range(.Cells(fr, fc + 1), .Cells(lr, fc + 1))
        Set c3 = .Range(.Cells(fr, fc + 2), .Cells(lr, fc + 2))
        Set c4 = .Range(.Cells(fr, fc + 3), .Cells(lr, fc + 3))
        Set c5 = .Range(.Cells(fr, fc + 4), .Cells(lr, fc + 4))

        Dim qCols As Range, clr As Long
        Select Case r
            Case U1
                Set qCols = Union(c1, c2, c3)   'question 1
                Select Case True
                    Case v < a3 Or v < a4:  Set qCols = Union(c1, c2)
                    Case v < a2:            Set qCols = c1
                End Select
            Case U2
                Set qCols = Union(c2, c3, c5)   'question 2
                Select Case True
                    Case v < a3 Or v < a4:  Set qCols = Union(c2, c5)
                    Case v < a1:            Set qCols = c5
                End Select
            Case U3
                Set qCols = Union(c3, c4)       'question 3
                Select Case True
                    Case v < a1 Or v < a2:  Set qCols = c4
                    Case v < a5:            Set qCols = c3
                End Select
            Case U4
                Set qCols = Union(c3, c4)       'question 4
                If v < a2 Or v < a5 Then Set qCols = c4
            Case U5
                Set qCols = Union(c1, c2, c3)   'question 5
                Select Case True
                    Case v < a3 Or v < a4:              Set qCols = Union(c1, c2)
                    Case v < a2 And (v < a3 Or v < a4): Set qCols = c1
                End Select
        End Select

        clr = RGB(255, 255, 255)
        Select Case v   'set colors based on current cell's value
            Case 1: clr = RGB(255, 0, 0)    'red
            Case 2: clr = RGB(255, 111, 0)  'orange
            Case 3: clr = RGB(255, 255, 0)  'yellow
            Case 4: clr = RGB(0, 255, 0)    'light green
            Case 5: clr = RGB(0, 111, 0)    'dark green
        End Select

        If v < 1 Then
          .UsedRange.Interior.Pattern = xlNone  'if cell value <1 clear all colors
        Else
          If Not qCols Is Nothing Then qCols.Interior.Color = clr
        End If
    End With
End Sub