Признаки с текстовыми и внутренними цветовыми критериями - PullRequest
Новая
       9

Признаки с текстовыми и внутренними цветовыми критериями

0 голосов
/ 05 февраля 2019

Я пытаюсь создать функцию показателей vba, которая имеет критерии множественности в разных столбцах.Мне нужно это только для подсчета ячеек в столбце E, которые имеют внутренний цвет, если соответствующая строка в столбце C имеет конкретное текстовое значение.

Например: Подсчитывать только ячейку E10, если C10 имеет значение "TL" иE10 имеет внутренний цвет Зеленый

Я использую этот код VBA для подсчета количества цветовых ячеек интерьера в диапазоне: 

 Function countif_by_color(rl As Range, r2 As Range) As Long

 Application.Volatile
 Dim x As Long
 Dim cel As Range

 x = 0

 For Each cel In rl
     If cel.Interior.color = r2.Interior.color Then
     x = x + 1
     End If
 Next

 countif_by_color = x
 End Function

И я пытался использовать его с этой формулой (A13 - цвет, который я хочу посчитать): 

 =(COUNTIFS($C$21:$C$101,"=TL",E21:E101,(countif_by_color(E21:E101,A13))))

Но это, по сути, приравнивает зеленые ячейки в столбце E к числовому значению, которое изменяет критерий счетчика для подсчета ячеек с этим числовым значением вместо цвета.

Я хочу изменить VBA функции countif_by_color, чтобы иметь несколько критериев, например, функцию countifs ... заранее спасибо!

1 Ответ

0 голосов
/ 05 февраля 2019

Вот countifs_by_color UDF, который использует ParameterArray для принятия переменного числа диапазонов.Примечание: он не обрабатывает формат формулы массива, как CountIfS.Если вам нужно, это потребует модификации. 

Function countifs_by_color(ParamArray var() As Variant) As Variant
    Application.Volatile

    Dim criteria_range As Range
    Dim criteria As Range
    Dim cel As Range
    Dim criteria_idx As Long
    Dim critera_rows As Long
    Dim critera_cols As Long
    Dim result_no_match() As Boolean
    Dim criteria_color As Variant
    Dim cell_idx As Long
    Dim match_count As Long

    ' must have even number of parameters
    If ((UBound(var) - LBound(var)) Mod 2) = 0 Then GoTo InvalidParameters

    'capture first range size
    critera_rows = var(LBound(var)).Rows.Count
    critera_cols = var(LBound(var)).Columns.Count

    'must be one row or one column
    If critera_rows <> 1 And critera_cols <> 1 Then GoTo InvalidParameters

    'size array to capture matches
    ReDim result_no_match(1 To IIf(critera_rows > 1, critera_rows, critera_cols)) 'initialises to all False

    For criteria_idx = LBound(var) To UBound(var) Step 2
        Set criteria_range = var(criteria_idx)
        Set criteria = var(criteria_idx + 1)

        'criteria must be single cell
        If criteria.Count <> 1 Then GoTo InvalidParameters

        'all criteria_rane must be same size
        If criteria_range.Rows.Count <> critera_rows Or criteria_range.Columns.Count <> critera_cols Then GoTo InvalidParameters

        'get color of criteria cell to avoid unnecassary sheet references
        criteria_color = criteria.Interior.Color

        'check each cell in criteria_range
        For cell_idx = 1 To criteria_range.Cells.Count
            'if cell has not already been invalidated
            If Not result_no_match(cell_idx) Then
                'compare colors
                If criteria_range.Cells(cell_idx).Interior.Color <> criteria_color Then
                    'no match, invalidate cell
                    result_no_match(cell_idx) = True
                End If
            End If
        Next
    Next

    'count matches
    For cell_idx = LBound(result_no_match) To UBound(result_no_match)
        If Not result_no_match(cell_idx) Then
            match_count = match_count + 1
        End If
    Next

    countifs_by_color = match_count
Exit Function
InvalidParameters:
    countifs_by_color = CVErr(xlErrValue)
End Function

Пример приложения

Example

...