Доброго дня, коллеги.
Т.к. я не являюсь программистом в его сакраментальной трактовке  прошу Вас помочь мне разобраться с одной проблемой.
Компилятор VBA Ну никак не хочет кушать вот такую конструкцию:
| Код |
If Application.Evaluate("=И(СУММ($C6:$E6)>0;СУММ(F6:G6)=0)") Then
ActiveCondition = Ndx
Exit Function
End If
|
Ошибка 2015 - Type mismatch
3 часа угробил - не могу понять, что не так.
Данный код, лишь фрагмент функции- не мой, взят с сайта http://www.cpearson.com.
Моя задача - получить цвет ячейки окрашенной условным форматированием. Соответсвенно цвет и кол-во ячеек будет постоянно меняться. Мне нужна была функция, которая бы это все считала. У уважаемого коллеги, чей сайт я выложил выше - все работает, но к сожалению на простых формулах, типа "=100" и т.д. С моей же формулой - не хочет ;-(. Сама формула - рабочая, условное форматирование по ней отрабатывает четко.
Выкладывю текст самих функций:
| Код |
Function RangeOfColor(TestRange As Range, _
ColorIndex As Long, Optional OfText As Boolean = False) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RangeOfColors
' This function returns a Range object containing the individual cells of
' TestRange whose Font (if OfText is True) or Interior (if OfText is False or
' omitted) has the color index specified by ColorIndex. Note that the function
' may return Nothing.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim R As Range
Dim RR As Range
Dim CI As Long
If ColorIndex = 0 Then
If OfText = False Then
CI = xlColorIndexNone
Else
CI = xlColorIndexAutomatic
End If
End If
If ColorIndex <> 0 Then
If IsValidColorIndex(ColorIndex) = False Then
Exit Function
End If
End If
For Each R In TestRange.Cells
If OfText = False Then
If R.Interior.ColorIndex = CI Then
If RR Is Nothing Then
Set RR = R
Else
Set RR = Application.Union(RR, R)
End If
End If
Else
If RR Is Nothing Then
Set RR = R
Else
Set RR = Application.Union(RR, R)
End If
End If
Next R
Set RangeOfColor = RR
End Function
Function ColorNameOfRGB(RGBLong As Long) As String
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ColorNameOfRGB
' Returns the name of the color specified by RGBLong
' if RGBLong is in the application default pallet.
' Otherwise, returns vbNullString.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim n As Long
Dim V As Variant
If IsValidRGBLong(RGBLong) = False Then
Exit Function
End If
V = Application.Match(RGBLong, ThisWorkbook.Colors, 0)
If IsError(V) = True Then
Exit Function
End If
V = DefaultColorNames(V)
If V <> vbNullString Then
ColorNameOfRGB = V
End If
End Function
Function ActiveCondition(Rng As Range) As Integer
Dim Ndx As Long
Dim FC As FormatCondition
Dim Temp As Variant
Dim Temp2 As Variant
If Rng.FormatConditions.Count = 0 Then
ActiveCondition = 0
Else
For Ndx = 1 To Rng.FormatConditions.Count
Set FC = Rng.FormatConditions(Ndx)
Select Case FC.Type
Case xlCellValue
Select Case FC.Operator
Case xlBetween
Temp = GetStrippedValue(FC.Formula1)
Temp2 = GetStrippedValue(FC.Formula2)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _
CDbl(Rng.Value) <= CDbl(FC.Formula2) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value >= Temp And _
Rng.Value <= Temp2 Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlGreater
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) > CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value > Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) = CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Temp = Rng.Value Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlGreaterEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value >= Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlLess
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) < CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value < Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlLessEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Rng.Value <= Temp Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlNotEqual
Temp = GetStrippedValue(FC.Formula1)
If IsNumeric(Temp) Then
If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Temp <> Rng.Value Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case xlNotBetween
Temp = GetStrippedValue(FC.Formula1)
Temp2 = GetStrippedValue(FC.Formula2)
If IsNumeric(Temp) Then
If Not (CDbl(Rng.Value) <= CDbl(FC.Formula1)) And _
(CDbl(Rng.Value) >= CDbl(FC.Formula2)) Then
ActiveCondition = Ndx
Exit Function
End If
Else
If Not Rng.Value <= Temp And _
Rng.Value >= Temp2 Then
ActiveCondition = Ndx
Exit Function
End If
End If
Case Else
Debug.Print "UNKNOWN OPERATOR"
End Select
Case xlExpression
If Application.Evaluate(FC.Formula1) Then ' Çàáàíèë, èìõî íå ðàáîòàåòü áëÿ ñ òàêèìè ôîðìóëàìè.
'If FC.Formula1 <> " " Then
ActiveCondition = Ndx
Exit Function
End If
Case Else
Debug.Print "UNKNOWN TYPE"
End Select
Next Ndx
End If
ActiveCondition = 0
End Function
'''''''''''''''''''''''''''''''''''''''
Function ColorIndexOfCF(Rng As Range, _
Optional OfText As Boolean = False) As Integer
Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
If OfText = True Then
ColorIndexOfCF = Rng.Font.ColorIndex
Else
ColorIndexOfCF = Rng.Interior.ColorIndex
End If
Else
If OfText = True Then
ColorIndexOfCF = Rng.FormatConditions(AC).Font.ColorIndex
Else
ColorIndexOfCF = Rng.FormatConditions(AC).Interior.ColorIndex
End If
End If
End Function
'''''''''''''''''''''''''''''''''''''''
Function ColorOfCF(Rng As Range, Optional OfText As Boolean = False) As Long
Dim AC As Integer
AC = ActiveCondition(Rng)
If AC = 0 Then
If OfText = True Then
ColorOfCF = Rng.Font.Color
Else
ColorOfCF = Rng.Interior.Color
End If
Else
If OfText = True Then
ColorOfCF = Rng.FormatConditions(AC).Font.Color
Else
ColorOfCF = Rng.FormatConditions(AC).Interior.Color
End If
End If
End Function
'''''''''''''''''''''''''''''''''''''''
Function GetStrippedValue(CF As String) As String
Dim Temp As String
If InStr(1, CF, "=", vbTextCompare) Then
Temp = Mid(CF, 3, Len(CF) - 3)
If Left(Temp, 1) = "=" Then
Temp = Mid(Temp, 2)
End If
Else
Temp = CF
End If
GetStrippedValue = Temp
End Function
'''''''''''''''''''''''''''''''''''''''
Function CountOfCF(InRange As Range, _
Optional Condition As Integer = -1) As Long
Dim Count As Long
Dim Rng As Range
Dim FCNum As Integer
For Each Rng In InRange.Cells
FCNum = ActiveCondition(Rng)
If FCNum > 0 Then
If Condition = -1 Or Condition = FCNum Then
Count = Count + 1
End If
End If
Next Rng
CountOfCF = Count
End Function
'''''''''''''''''''''''''''''''''''''''
Function SumByCFColorIndex(Rng As Range, CI As Integer) As Double
Dim R As Range
Dim Total As Double
For Each R In Rng.Cells
If ColorIndexOfCF(R, False) = CI Then
Total = Total + R.Value
End If
Next R
SumByCFColorIndex = Total
End Function
|
Если кому-то пригодится-буду только рад. Если у кого есть свои наработки - прошу поделится. На поиски кода нашего зарубежноо коллеги у меня ушло 5 часов. ;)
Прошу помощи. |
