' PGC Nov 06
' Delinks formats from conditions in cells with conditional formatting.
' The cells keep the format that was enabled with the conditional formatting
' but as normal format. Background and Font Colour
' Oct 07
' Added Borders, Font Style, Underline and Strikethrough
' Patejl Feb 12
' Fixed Excel 2007 compatibility issues

Sub ConditionalFormatDelink(rRng As Range)
Dim vConditionsSyntax, rCell As Range, rCFormat As Range, iCondition As Integer
Dim sFormula As String, vCSyntax, vOperator, iBorder As Integer, vBorders
Dim firstRow As Long, firstColumn As Long, firstCell As Range, conditionArea As Range

vBorders = Array(xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom)

' Syntax for "Value is" Conditions
vConditionsSyntax = Array( _
    Array(xlEqual, "CellRef = Condition1"), _
    Array(xlNotEqual, "CellRef <> Condition1"), _
    Array(xlLess, "CellRef < Condition1"), _
    Array(xlLessEqual, "CellRef <= Condition1"), _
    Array(xlGreater, "CellRef > Condition1"), _
    Array(xlGreaterEqual, "CellRef >= Condition1"), _
    Array(xlBetween, "AND(CellRef >= Condition1, CellRef <= Condition2)"), _
    Array(xlNotBetween, "OR(CellRef < Condition1, CellRef > Condition2)") _
)

' Get cells with format
On Error GoTo EndSub
Set rCFormat = rRng.SpecialCells(xlCellTypeAllFormatConditions)

On Error Resume Next
For Each rCell In rCFormat ' Loops through all the cells with conditional formatting
    If Not IsError(rCell) Then ' skips cells with error
        rCell.Activate
        With rCell.FormatConditions
            For iCondition = 1 To .Count ' loops through all the conditions
                
                'Locate the first cell in the AppliesTo area (used as a reference for sFormula)
                firstRow = .Item(iCondition).AppliesTo.Row
                firstColumn = .Item(iCondition).AppliesTo.Column
                
                If .Item(iCondition).AppliesTo.Areas.Count > 1 Then
                    For Each conditionArea In .Item(iCondition).AppliesTo.Areas
                        If conditionArea.Row < firstRow Then firstRow = conditionArea.Row
                        If conditionArea.Column < firstColumn Then firstColumn = conditionArea.Column
                    Next conditionArea
                End If

                Set firstCell = Cells(firstRow, firstColumn)
                
                sFormula = .Item(iCondition).Formula1
                Err.Clear
                vOperator = .Item(iCondition).Operator
                If Err <> 0 Then ' "Formula Is"
                    Err.Clear
                Else ' "Value Is"
                    For Each vCSyntax In vConditionsSyntax ' checks all the condition types
                        If .Item(iCondition).Operator = vCSyntax(0) Then
                            ' build the formula equivalent to the condition
                            sFormula = Replace(vCSyntax(1), "Condition1", Evaluate(sFormula))
                            sFormula = Replace(sFormula, "CellRef", rCell.Address)
                            sFormula = Replace(sFormula, "Condition2", Evaluate(.Item(iCondition).Formula2))
                            Exit For
                        End If
                    Next vCSyntax
                End If
                
                'Uncomment when needed: Fix formula (Czech list separator -> US list separator)
                'sFormula = Replace(sFormula, ",", ".")
                'sFormula = Replace(sFormula, ";", ",")
                
                'Shift formula (relate it to the first cell of the AppliesTo area)
                sFormula = Application.ConvertFormula(Formula:=sFormula, fromReferenceStyle:=xlA1, toReferenceStyle:=xlR1C1, RelativeTo:=firstCell)
                sFormula = Application.ConvertFormula(Formula:=sFormula, fromReferenceStyle:=xlR1C1, toReferenceStyle:=xlA1, RelativeTo:=rCell)
                
                If Evaluate(sFormula) Then
                    ' The cell has a condition = True. Delink the format from the conditional formatting
                    
                    ' Background
                    If Not IsNull(.Item(iCondition).Interior.ColorIndex) Then _
                        rCell.Interior.Color = .Item(iCondition).Interior.Color
                    
                    ' Font
                    If Not IsNull(.Item(iCondition).Font.ColorIndex) Then _
                        rCell.Font.Color = .Item(iCondition).Font.Color
                    If Not IsNull(.Item(iCondition).Font.FontStyle) Then _
                        rCell.Font.FontStyle = .Item(iCondition).Font.FontStyle
                    If Not IsNull(.Item(iCondition).Font.Strikethrough) Then _
                        rCell.Font.Strikethrough = .Item(iCondition).Font.Strikethrough
                    If Not IsNull(.Item(iCondition).Font.Underline) Then _
                        rCell.Font.Underline = .Item(iCondition).Font.Underline
                    
                    ' Borders
                    With .Item(iCondition)
                        For iBorder = 1 To 4
                            If .Borders(iBorder).LineStyle <> xlNone Then
                                rCell.Borders(vBorders(iBorder - 1)).LineStyle = .Borders(iBorder).LineStyle
                                rCell.Borders(vBorders(iBorder - 1)).ColorIndex = .Borders(iBorder).ColorIndex
                                rCell.Borders(vBorders(iBorder - 1)).Weight = .Borders(iBorder).Weight
                            End If
                        Next iBorder
                    End With
                    
                    'Exit on StopIfTrue
                    If .Item(iCondition).StopIfTrue Then Exit For
                End If
            Next iCondition
        End With
    End If
    rCell.FormatConditions.Delete ' deletes the cell's conditional formatting
Next rCell
EndSub:
End Sub
Sub BreakCF()
   Call ConditionalFormatDelink(Range("A1:K40"))
End Sub