正在检查有条件格式化的单元格的颜色索引

Question

我正在尝试计数有条件着色的细胞（以及满足的任何其他条件）。

检查颜色索引的代码如下：

Function CheckColor(rng As Range)
    Dim arr()
    'ReDim arr(1 To rng.Count, 1 To 1) ' or use this instead of arr = rng.Value2
    arr = rng.Value2   ' arr Type in the Locals window shows as Variant(1 To 11, 1 To 1)
    For i = 1 To rng.Cells.Count
        arr(i, 1) = rng.Cells(i, 1).Interior.ColorIndex = 15
    Next i
    CheckColor = arr
End Function

然而，我发现条件格式会使颜色索引倾斜。有人能帮我修复上面的函数来检查有条件格式化单元格的颜色代码吗？

Answer 1

这不是一项琐碎的任务。

原始解决方案发布在此处（现在可能处于脱机状态）：http://www.excelfox.com/forum/showthread.php/338-Get-Displayed-Cell-Color-（无论是否来自条件格式）

' Arguments
' ----------------
' Cell - Required Range, not a String value, for a **single** cell
'
' CellInterior - Optional Boolean (Default = True)
'                True makes function return cell's Interior Color or ColorIndex based on
'                the ReturnColorIndex argument False makes function return Font's Color or
'                ColorIndex based on the ReturnColorIndex argument
'
' ReturnColorIndex - Optional Boolean (Default = True)
'                    True makes function return the ColorIndex for the cell property determined
'                    by the CellInterior argument False make function return the Color for the
'                    cell property determined by the CellInterior argument
'
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
                        Optional ReturnColorIndex As Long = True) As Long
  Dim X As Long, Test As Boolean, CurrentCell As String
  If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
  CurrentCell = ActiveCell.Address
  For X = 1 To Cell.FormatConditions.Count
    With Cell.FormatConditions(X)
      If .Type = xlCellValue Then
        Select Case .Operator
          Case xlBetween:      Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
          Case xlNotBetween:   Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
          Case xlEqual:        Test = Evaluate(.Formula1) = Cell.Value
          Case xlNotEqual:     Test = Evaluate(.Formula1) <> Cell.Value
          Case xlGreater:      Test = Cell.Value > Evaluate(.Formula1)
          Case xlLess:         Test = Cell.Value < Evaluate(.Formula1)
          Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
          Case xlLessEqual:    Test = Cell.Value <= Evaluate(.Formula1)
        End Select
      ElseIf .Type = xlExpression Then
        Application.ScreenUpdating = False
        Cell.Select
        Test = Evaluate(.Formula1)
        Range(CurrentCell).Select
        Application.ScreenUpdating = True
      End If
      If Test Then
        If CellInterior Then
          DisplayedColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
        Else
          DisplayedColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
        End If
        Exit Function
      End If
    End With
  Next
  If CellInterior Then
    DisplayedColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
  Else
    DisplayedColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
  End If
End Function