Function СЧЁТУНИКЕСЛИМН(rngU As Range, _
    rng1 As Range, kr1 As Variant, _
    Optional rng2 As Range, Optional kr2 As Variant, _
    Optional rng3 As Range, Optional kr3 As Variant, _
    Optional rng4 As Range, Optional kr4 As Variant, _
    Optional rng5 As Range, Optional kr5 As Variant) As Double
'аргументы:
'rngU - диапазон отбора уникальных значений, обязательный
'rng1 - диапазон условий 1, обязательный
'kr1 - условие 1, обязательный
'rng2 - диапазон условий 1, необязательный
'kr2 - условие 1, необязательный
'и т.д. до 5-ти условий

'определение необязательных аргументов, если они не заданы
If rng2 Is Nothing Then
    Set rng2 = rng1
    kr2 = kr1
End If
If rng3 Is Nothing Then
    Set rng3 = rng1
    kr3 = kr1
End If
If rng4 Is Nothing Then
    Set rng4 = rng1
    kr4 = kr1
End If
If rng5 Is Nothing Then
    Set rng5 = rng1
    kr5 = kr1
End If

Dim cl As Range

СЧЁТУНИКЕСЛИМН = 0
On Error Resume Next
    With New Collection
        For Each cl In rngU
            If rng1.Parent.Cells(cl.Row, rng1.Column).Value Like kr1 And _
                rng2.Parent.Cells(cl.Row, rng2.Column) Like kr2 And _
                rng3.Parent.Cells(cl.Row, rng3.Column) Like kr3 And _
                rng4.Parent.Cells(cl.Row, rng4.Column) Like kr4 And _
                rng5.Parent.Cells(cl.Row, rng5.Column) Like kr5 Then
                    .Add cl, CStr(cl)
                If Err = 0 Then
                    СЧЁТУНИКЕСЛИМН = СЧЁТУНИКЕСЛИМН + 1
                Else
                    Err.Clear
                End If
            End If
        Next
    End With
End Function