Функция VBA для проверки условного форматирования ячейки в Excel
Я написал нижеприведенную функцию, чтобы проверить, активировано ли в ячейке условное форматирование на основе заполнения ячейки.
Function cfTest(inputCell)
If inputCell.DisplayFormat.Interior.Color <> 16777215 Then
cfTest = True
Else
cfTest = False
End If
End Function
Это не работает однако. Сказав это, этот метод делает.
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
Может кто-нибудь объяснить мне, почему функция не будет работать?
Приветствия.
РЕДАКТИРОВАТЬ: обновленная функция, но не работает для условного форматирования
Function cfTest(inputCell)
If inputCell.Interior.ColorIndex <> -4142 Then
cfTest = True
Else
cfTest = False
End If
End Function
6 ответов
Вот рабочая демоверсия, если желаемый результат. Столбец E просматривает столбец D и отображает значение TRUE, если оно условно отформатировано цветом заливки ячейки. т.е. нажимаем на имя 'Bob', и условное форматирование подсвечивает ячейку с помощью кода ниже
=IF(AND(CELL("row")=ROW(D1),CELL("col")=COLUMN(D1)),TRUE)
Нажмите на другое имя, и результат будет тот же.
Однако, когда я щелкаю имена в другой ячейке, выбранная фамилия остается выделенной, создавая впечатление, что кнопка все еще нажата.
Код VBA заключается в следующем.
Это находится внутри кода Sheet1:
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
И это сам метод:
Sub cfTest()
Range("E:E").ClearContents
If ActiveCell.DisplayFormat.Interior.color <> 16777215 Then
ActiveCell.Offset(0, 1) = True
End If
End Sub
Приложение, которое я построил на этом примере, имело гораздо больше, но, возвращаясь к опубликованному вопросу, метод cfTest() позволил мне проверить, была ли ячейка отформатирована условно на основе заполнения ячейки.
Я не уверен, почему это так, но, возможно, это поможет. VB, кажется, не разрешает доступ к цвету ячеек, когда этот цвет основан на условном форматировании.
Например..
'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
Тем не менее, есть причина, по которой вы не можете просто проверить ячейку для каких-либо действующих правил форматирования. Это устранит необходимость в UDF.
=IF(A1<50,False,True)
Вот две связанные функции, которые реализуют математические условия. Это немного менее сложно, чем версия Chip Pearson, а также менее полно, но я думаю, что это должно охватывать большинство случаев, и это не должно быть слишком сложным для расширения.
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
Это будет работать для некоторых общих операторов, но есть два других оператора (xlBetween и xlNotBetween), и есть другие типы условий, которые также должны быть перехвачены, и логика для некоторых из них будет немного сложнее, чем эта, Однако некоторые из них (например, панели данных) по своей сути сообщают о наличии условия, поэтому никакой обработки не потребуется.
Вот ссылка на полную документацию:
Я бы выполнил предварительную проверку индекса цвета, который вы используете для этого:
Function cfTest_color_chk(inputCell As Range)
cfTest_color_chk = inputCell.Interior.ColorIndex
End Function
Тогда твоя функция
Function cfTest(inputCell As Range)
If inputCell.Interior.ColorIndex <> -4142 Then
cfTest = True
Else
cfTest = False
End If
End Function
Другое решение, чтобы сделать вещи непоколебимыми, это объединить обе функции, так что cfTest принимает cfTest_color_chk в качестве параметра, а cfTest_color_chk возвращает значение цвета для соответствия...
Надеюсь это поможет
паскаль
Вот UDF, который позволяет проверить, является ли aTrue/Falseдля одной из ячеек, к которой он применяется. Он предназначен только дляFormatConditionsсOperatorсвойствоxlExpression, чтобы завершить версию Чипа Пирсона, которая тестирует только "фиксированные"Formula1изFormatConditionна первой ячейке своегоAppliesTo.
Версия VBA UDF:
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 также можно использовать для перевода, но с теми же ограничениями, что и при использованииtemp
Версия ThisSheet UDF (только если в настройках установлен английский язык):
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
Пример в VBA:
?CheckFC_VBA(Selection.FormatConditions(1), Selection)
Пример на листе (в зависимости от текущего разделителя списка):
=CheckFC_ThisSheet_EN(1, A1)
=CheckFC_ThisSheet_EN(1; A1)
Версия VBA UDF более эффективна, чем версия ThisSheet UDF, потому что она может переводить локальную формулу на английский язык, что требуется для этого решения, и она работает в любых случаях, в то время как версия ThisSheet может тестировать FC только на том листе, где она находится. используется (если только все ссылки в FC полностью не указаны с именем листа, напримерSheet1!A1вместо того, чтобы простоA1...). Спасибо @Gserg за указание на все это.
ЧТО СДЕЛАТЬ: обновить версию VBA (удалив.Activate()метода) и версии ThisSheet (до версии Sheet, способной проверять FC на других листах), можно проанализировать формулу FC и заменить любые неявные ссылки на явные ссылки именем родительского листа перед вызовом методаApplication.Evaluate()функция. Нет встроенного способа проанализировать формулу и получить ссылку, как это делает Excel. Для этого есть несколько идей, ни одна из которых не является 100% верной:
- /questions/43808710/est-li-v-excel-vstroennyij-metod-analiza-formul-te-poluchit-spisok-vklyuchennyih-ssyilok-range/43808721#43808721 + http://www.cpearson.com/excel/splitondelimiters.aspx
- /questions/10930741/najti-vse-ispolzuemyie-ssyilki-v-formule-excel/10930756#10930756
- /questions/41231733/razbor-i-izvlechenie-ssyilok-na-yachejki-iz-formul-excel/41231748#41231748 (FormatCondition не имеет свойства DirectDependants, поэтому снова потребуется временной диапазон...)
- https://github.com/spreadsheetlab/XLParser
РЕДАКТИРОВАТЬ: чтобы ответить на мой собственный TO DO, и в качестве примера, вот версия листа UDF:
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
Теперь, используя обходной путь, упомянутый в сообщении, указанном @GSerg, я ожидаю, что на самом деле можно создать международную пользовательскую функцию листа, способную переводить функции Excel в формулу. С температуройNameсоздается на лету вместо tempRange, я думаю, что риск краха из-за циклических ссылок будет сведен к нулю...
Хорошо, я знаю, что это старый вопрос, но я пытался понять то же самое и нашел другое решение.
Однако некоторые предостережения...
Это работает только в том случае, если вы точно знаете индекс условного формата или применяется только один условный формат (поскольку вы бы использовали индекс 1).
Форматирование применяется с использованием пользовательской функции, которую вы ввели, не зная других методов.
Длинная версия
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
В одну строку (хотя это не очень гибко)
Evaluate(Range.FormatConditions(1).Formula1) 'Where Range is substituted for the actual range in question
В ходе моего легкого тестирования оба смогли работать, но при этом у меня не было большого опыта, поэтому относитесь к ним с недоверием.