В потугах решить проблему преобразования условного форматирования в обычное макросом (не надстройкой - не получится, это обязательное и безоговорочное условие), наткнулся на работающий код:
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
'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
'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
И действительно - код работает!
Но, он понимает только два условия - условие и отсутствующее условия.
В документе же, в который требуется вставить этот код - четыре условия:
1. Если значение на 5% больше x - то ячейка зелёная
2. Если значение на 5% меньше х - то ячейка красная
3. Если значение меньше х от ДО 5% - то ячейка жёлтая
4. В других случаях форматирование не задано.
Код работает, но, учитывая лишь два условия - перекрашивает ячейки, попавшие под первое условие - в зелёный, все остальные в красный, вне зависимости от значений, просто потому, что не понимает, что есть ещё пункты 3 и 4.
В итоге на листах, где условное форматирование разное - получается полный рандом. Как расширить код до 4 условий? Автор кода мне не отвечает (код не сворован - он был в открытом доступе на англоязычном форуме).
