VBA function to test if cell is conditionally formatted in Excel

Question

I have written the function below to test if a cell has conditional formatting activated based upon the cell fill.

Function cfTest(inputCell)

    If inputCell.DisplayFormat.Interior.Color <> 16777215 Then
        cfTest = True
    Else
       cfTest = False
    End If
End Function

It does not work however. Saying that, this method does.

Sub myCFtest()
Dim R As Integer
R = 2
Do
    If Range("I" & R).DisplayFormat.Interior.Color <> 16777215 Then
        Range("K" & R).Value = True
    Else
        Range("K" & R).Value = False
    End If

    R = R + 1

Loop Until R = 20
End Sub

Can anyone explain to me why the function will not work?

Cheers.

EDIT: Updated function but not working for conditional formatting

Function cfTest(inputCell)
    If inputCell.Interior.ColorIndex <> -4142 Then
        cfTest = True
    Else
       cfTest = False
    End If
End Function

Answer 1

Ok so I know this is an old question, but I was trying to figure out this same thing and I found out another solution.

Some caveats though...

• This only works if you know for sure the index of the conditional format, or if there's just one conditional format applied (because you'd use index of 1)

• The formatting is applied using a custom function you entered in, unsure about the other methods.

Longish Version

Function RangeConditionValue(RNG as Range, Optional ByVal Indx as Long = 1) as boolean
    Dim FormatFormula as String, Result as boolean
    Dim F as FormatCondition
    On Error Resume next

    Set F = RNG.formatconditions(Indx)
    FormatFormula = F.Formula1
    Result = Evaluate(FormatFormula)

    On Error Goto 0

    RangeConditionValue = Result
End function

In one line (although this isn't super flexible)

Evaluate(Range.FormatConditions(1).Formula1) 'Where Range is substituted for the actual range in question

In my light testing both were able to work, but in also not extremely experienced so take with grain of salt.

Answer 2

Here is UDF that allows to check if a FormatCondition is True/False for one of the cells it applies to. It is intended only to FormatConditions with an Operator property of xlExpression, to complete Chip Pearson version, which only tests the "fixed" Formula1 of a FormatCondition on the first cell in its AppliesTo Range.

VBA UDF version:

Function CheckFC_VBA(fc As FormatCondition, rng As Range) As Variant 'fc must must be a member of rng.FormatConditions, and rng must be in fc.AppliesTo Range
    Set c = rng(1)
    If Intersect(c, fc.AppliesTo) Is Nothing Then Exit Function
    rng.Parent.Activate 'Application.Evaluate will work off the active sheet, whereas the fc may have come from another sheet at the moment of the call to this function
                        'this function can be called only from VBA because if called from a sheet it won't be able to change the active sheet
    If Application.LanguageSettings.LanguageID(MsoAppLanguageID.msoLanguageIDUI) <> 1033 Then
        'Français; France; fr-FR; 1036
        Set temp = Cells(Selection.Parent.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1, "A")
        temp.FormulaLocal = fc.Formula1
        strFormulaMoved$ = Application.ConvertFormula( _
                                                        Application.ConvertFormula(temp.Formula, XlReferenceStyle.xlA1, XlReferenceStyle.xlR1C1, , fc.AppliesTo(1)), _
                                                        XlReferenceStyle.xlR1C1, XlReferenceStyle.xlA1, , c)
        temp.ClearContents
    Else
        'English; United States; fr-FR; 1033
        
        strFormulaMoved$ = Application.ConvertFormula( _
                                                        Application.ConvertFormula(Replace(fc.Formula1, Application.International(xlListSeparator), ","), XlReferenceStyle.xlA1, XlReferenceStyle.xlR1C1, , fc.AppliesTo(1)), _
                                                        XlReferenceStyle.xlR1C1, XlReferenceStyle.xlA1, , c)
    End If
        CheckFC_VBA = Application.Evaluate(strFormulaMoved)
End Function

a Name could also be used to do the translation, but with the same limitations than using the temp Range

ThisSheet UDF version (only if local is set to English in settings):

Function CheckFC_ThisSheet_EN(fc_index As Integer, rng As Range) As Variant
    Set c = rng(1)
    Set fc = c.FormatConditions(fc_index)
    If Intersect(c, fc.AppliesTo) Is Nothing Then Exit Function
    'If Not rng.Parent Is Application.Caller.Parent Then Exit Function
    If Not rng.Parent Is ActiveSheet Then Exit Function
    If Application.LanguageSettings.LanguageID(MsoAppLanguageID.msoLanguageIDUI) <> 1033 Then
        'cannot translate automatically
    Else
        'English; United States; fr-FR; 1033
        
        strFormulaMoved$ = Application.ConvertFormula( _
                                                        Application.ConvertFormula(Replace(fc.Formula1, Application.International(xlListSeparator), ","), XlReferenceStyle.xlA1, XlReferenceStyle.xlR1C1, , fc.AppliesTo(1)), _
                                                        XlReferenceStyle.xlR1C1, XlReferenceStyle.xlA1, , c)
    End If
        CheckFC_ThisSheet_EN = Application.Evaluate(strFormulaMoved)
End Function

Example in VBA:

?CheckFC_VBA(Selection.FormatConditions(1), Selection)

Example in a Sheet (depending on the current list separator):

=CheckFC_ThisSheet_EN(1, A1)
=CheckFC_ThisSheet_EN(1; A1)

The VBA UDF version is more potent than the ThisSheet UDF version because it can translate a local formula to english, which is required with this solution, and it works in any cases, while the ThisSheet version can only test FCs on the sheet where it is being used (unless all references in the FC are fully qualified with a sheet name like Sheet1!A1 instead of just A1...). Thanks @Gserg for pointing all that out.

TO DO: to upgrade the VBA version (by removing the .Activate() method) and the ThisSheet version (to a Sheet version capable to check FC in other sheets), one could parse the FC formula and replace any implicit references to explicit references with its parent sheet name, before calling the Application.Evaluate() function. There are no built-in way to parse a formula and get the reference as Excel does it. There are several ideas to do that, none 100% correct:

• https://stackoverflow.com/a/11458075/2981328 + http://www.cpearson.com/excel/splitondelimiters.aspx
• https://stackoverflow.com/a/33146900/2981328
• https://stackoverflow.com/a/50554353/2981328 (a FormatCondition does not have a DirectDependants property, so a temp Range would be needed again...)
• https://github.com/spreadsheetlab/XLParser

EDIT: to reply my own TO DO, and as an example, here is a Sheet UDF version:

Function CheckFC_Sheet_EN(fc_index As Integer, rng As Range) As Variant
    Set c = rng(1)
    Set fc = c.FormatConditions(fc_index)
    If Intersect(c, fc.AppliesTo) Is Nothing Then Exit Function
    If Application.LanguageSettings.LanguageID(MsoAppLanguageID.msoLanguageIDUI) <> 1033 Then
        'cannot translate automatically
        'Français; France; fr-FR; 1036
    Else
        'English; United States; fr-FR; 1033
        strFormulaMoved$ = Application.ConvertFormula( _
                                                        Application.ConvertFormula(MakeImplicitReferencesExplicit$(Replace(fc.Formula1, Application.International(xlListSeparator), ","), fc.Parent.Parent.Name), XlReferenceStyle.xlA1, XlReferenceStyle.xlR1C1, , fc.AppliesTo(1)), _
                                                        XlReferenceStyle.xlR1C1, XlReferenceStyle.xlA1, , c)
    End If
        CheckFC_Sheet_EN = Application.Evaluate(strFormulaMoved)
End Function

Function MakeImplicitReferencesExplicit$(strFormula$, strExternalLink$)
'USAGE:
'strExternalLink = "Feuil1"
'strExternalLink = "[Book1.xlsm]Feuil1 bis"
         
    Set objRegEx = CreateObject("VBScript.RegExp")
    With objRegEx
        .IgnoreCase = True
        .Global = True
        .MultiLine = True
    End With
    
    'objRegEx.Pattern = """.*?"""  'remove expressions (with lazy quantifier)
    'strFormula = objRegEx.Replace(strFormula, "")
    
    objRegEx.Pattern = """.*?"""
    
    'replace without changing the position of each character in the string
    If objRegEx.test(strFormula) Then 'matches
        Set vResult = objRegEx.Execute(strFormula)
        If vResult.Count > 0 Then
            For Each vMatch In vResult
                strFormula2 = Left(strFormula, vMatch.FirstIndex) & """" & String(vMatch.Length - 2, " ") & """" & Mid(strFormula, vMatch.FirstIndex + 1 + vMatch.Length)
                'strFormula2 = Left(strFormula, vMatch.FirstIndex) & String(vMatch.Length, "_") & Mid(strFormula, vMatch.FirstIndex + 1 + vMatch.Length)
            Next
        Else
            strFormula2 = strFormula
        End If
    Else
        strFormula2 = strFormula
    End If
    
    'basic:
    'strSearchPattern$ = "(([A-Z])+(\d)+)"
    'better:
    strSearchPattern$ = _
        "(['].*?['!])?" & _
        "" & _
        "([[A-Z0-9_]+[!])?" & _
        "" & _
        "(\$?[A-Z]+\$?\d+:\$?[A-Z]+\$?\d+" & _
        "|" & _
        "\$?[A-Z]+:\$?[A-Z]+" & _
        "|" & _
        "\$?\d+:\$?\d+" & _
        "|" & _
        "\$?[A-Z]+\$?\d+)"
    '- match an optional External link:                  (['].*?['!])?
    '- match an optional Sheet name:                     ([[A-Z0-9_]+[!])?
    '- match the following alternation in prioritized order (*) (with optional $ symbols)
    '- a range with row numbers and column letters:     \$?[A-Z]+\$?(\d)+:\$?[A-Z]+\$?(\d)+
    '- a range without row numbers (entire columns):    \$?[A-Z]+:\$?[A-Z]+
    '- a range without column letters (entire rows):    \$?(\d)+:\$?(\d)+
    '- single-cell references:                          \$?[A-Z]+\$?(\d)+
    '*
    'because the RegEx engine is eager
    'https://www.regular-expressions.info/alternation.html
    
    objRegEx.Pattern = strSearchPattern
    
    If objRegEx.test(strFormula2) Then 'matches
        Set vResult = objRegEx.Execute(strFormula2)
        If vResult.Count > 0 Then
            Dim lngOffset&
            strFormula3$ = strFormula
            strExternalLink = "'" & strExternalLink & "'" & "!"
            For Each vMatch In vResult
                If IsEmpty(vMatch.SubMatches(0)) And IsEmpty(vMatch.SubMatches(1)) Then
                    strExplicitRef$ = strExternalLink & vMatch.Value
                Else
                    strExplicitRef$ = vMatch.Value
                End If
                strFormula3 = Left(strFormula3, lngOffset + vMatch.FirstIndex) & strExplicitRef & Mid(strFormula3, lngOffset + vMatch.FirstIndex + 1 + vMatch.Length)
                lngOffset = lngOffset + Len(strExternalLink)
            Next
            MakeImplicitReferencesExplicit = strFormula3
        Else
            MakeImplicitReferencesExplicit = strFormula
        End If
    End If
    
End Function

Now, using the workaround mentioned in the post pointed out by @GSerg, I expect it is possible to actually make an international Sheet UDF capable of translating Excel functions in the formula. With a temp Name created on the fly instead of temp Range, I think the risk of a crash due to circular referencing would be reduce to zero...

Answer 3

I'm not sure as to the why of this but maybe it'll help. VB doesn't seem to allow access to a cells color when that color is based on conditional formatting.

For example..

'cell A1 colored yellow through conditional formatting
MsgBox Range("A1").Interior.ColorIndex
'returns the incorrect result of -4142 regardless of cell color

'cell B1 colored yellow via the fill option on the ribbon
MsgBox Range("B1").Interior.ColorIndex
'returns the correct result of 6

That being said, is there a reason you couldn't just test the cell for whatever formatting rules you have in effect. That would eliminate the need for a UDF.

=IF(A1<50,False,True)

Answer 4

Here is a working demo if the desired result. Column E looks at column D and displays the value TRUE if it is conditionally formatted by cell fill color. i.e. click on the name 'Bob', and conditionally formatting highlights the cell via the code below

=IF(AND(CELL("row")=ROW(D1),CELL("col")=COLUMN(D1)),TRUE)

Click on another name, and the same result occurs.

However, when I click off the names onto another cell, I last name selected remains highlighted, giving the impression of a button still depressed.

The VBA code behind is as follows.

This sits within the Sheet1 code:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Column = 4 And Target.Row <= Application.WorksheetFunction.CountA(Range("D:D")) Then
    Range("D:D").Calculate
    Call cfTest

End If

End Sub

And this is the method itself:

Sub cfTest()

Range("E:E").ClearContents

If ActiveCell.DisplayFormat.Interior.color <> 16777215 Then
    ActiveCell.Offset(0, 1) = True
End If

End Sub

The application I ended up building off this example had much more too it, but going back to the posted question, the cfTest() method allowed me to test if a cell was conditionally formatted based upon cell fill.

Answer 5

Here are two related functions that implement mathematical conditions. This is slightly less complicated than the Chip Pearson version, and also less complete, but I think this should cover most cases, and this shouldn't be too difficult to extend.

Function isConditionallyFormatted(rng As Range) As Boolean

    Dim f As FormatCondition

    On Error Resume Next
    isConditionallyFormatted = False
    For Each f In rng.FormatConditions

        isConditionallyFormatted = checkFormula(rng.Value, f.operator, f.Formula1)
        isConditionallyFormatted = checkFormula(rng.Value, f.operator, f.Formula2)

        Next

End Function

Function checkFormula(rng As Variant, operator As Variant, condition As Variant)

    On Error GoTo errHandler:

    Dim formula As String
    condition = Right(condition, Len(condition) - 1)
    Select Case operator

            Case xlEqual: formula = rng & "=" & condition
            Case xlGreater: formula = rng & ">" & condition
            Case xlGreaterEqual: formula = rng & ">=" & condition
            Case xlLess: formula = rng & "<" & condition
            Case xlLessEqual: formula = rng & "<=" & condition
            Case xlExpression: formula = condition

            End Select

    checkFormula = Evaluate(formula)
Exit Function
errHandler:
    Debug.Print Err.Number & " : " & Err.Description
End Function

This will work for some common operators, but there are two other operators (xlBetween and xlNotBetween) and there are other types of condition that would have to be caught as well, and the logic for some of those would be a little more complicated than this. Some of them, however (like databars), inherently convey that there is a condition, so no processing would be necessary.

Here is a link to the full documentation:

http://msdn.microsoft.com/en-us/ff835850(v=office.15)

Answer 6

I would perform a prior check for the color index your condition is for using this:

Function cfTest_color_chk(inputCell As Range)
  cfTest_color_chk = inputCell.Interior.ColorIndex
End Function

Then your function

Function cfTest(inputCell As Range)
  If inputCell.Interior.ColorIndex <> -4142 Then
      cfTest = True
  Else
     cfTest = False
  End If
End Function

Another solution to make things rock solid is to combine both function so that cfTest takes cfTest_color_chk as a parameter and cfTest_color_chk will return the value of the color to match...

Hope this helps

Pascal