Присваивание значений необязательным аргументам пользовательской функции (UDF) в коде самой функции, как массово присвоить значение необязательным аргументам
Добрый вечер, коллеги! При решении вопроса в ЭТОЙ теме написал UDF, которая подсчитывает количество уникальных значений по двум условиям. У Автора той темы возник вопрос об увеличении количества условий поиска уникальных. В процессе доработки возник вопрос : Как присвоить необязательным аргумента значения по умолчанию, НО не константы?
Объявление функции таким способом Function СЧЁТУНИКЕСЛИМН(rngU As Range, _ rng1 As Range, kr1 As Variant, Optional rng2 As Range = rng1, Optional kr2 As Variant = kr1, .........) конечно же привел к ошибке.
Доработал функцию таким методом, но, мне кажется, есть какой-то другой способ. Или мне действительно кажется? Как быть при действительно большом количестве однотипных необязательных аргументов? Спасибо
Скрытый текст
Код
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
При таком подходе можно лишь укоротить код, сделав цикл по всем аргументам. Т.е. заносим их предварительно в массив и циклом по нему, проверяя на Nothing или что там еще. Хотя если надо "растягивать" на неопределенное кол-во аргументов - лучше применять ParamArray. Сейчас уже не успею накатать пример применения, но в сети и на форуме точно есть пример применения.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
Option Explicit
Option Base 1 ' <---!!!---
Function СЧЁТУНИКЕСЛИМН2(rngU, rng1, kr1, _
Optional rng2, Optional kr2, Optional rng3, Optional kr3, Optional rng4, Optional kr4, Optional rng5, Optional kr5, _
Optional rng6, Optional kr6, Optional rng7, Optional kr7, Optional rng8, Optional kr8, Optional rng9, Optional kr9)
Dim rnglist(), krlist(), rngs(0 To 9), krs(9), m&, n&, i&, j&, cnt&
rngs(0) = rngU
rnglist = Array(rng2, rng3, rng4, rng5, rng6, rng7, rng8, rng9)
krlist = Array(kr2, kr3, kr4, kr5, kr6, kr7, kr8, kr9)
For j = 2 To 9
If Not (IsMissing(rnglist(j - 1)) Or IsMissing(krlist(j - 1))) Then
m = m + 1: rngs(m) = rnglist(j - 1): krs(m) = krlist(j - 1)
End If
Next
m = m + 1: rngs(m) = rng1: krs(m) = kr1
On Error GoTo erex
n = UBound(rngs(0))
For j = 1 To m
If UBound(rngs(j)) <> n Or IsArray(krs(j)) Then GoTo erex
Next
On Error Resume Next
With New Collection
For i = 1 To n
For j = 1 To m
If Not (rngs(j)(i, 1) Like krs(j)) Then Exit For
Next
If j > m Then
.Add 0, CStr(rngs(0)(i, 1))
If Err = 0 Then cnt = cnt + 1 Else Err.Clear
End If
Next
End With
СЧЁТУНИКЕСЛИМН2 = cnt
Exit Function
erex:
If Err Then Err.Clear
СЧЁТУНИКЕСЛИМН2 = CVErr(xlErrValue)
End Function
Как и обещал выкладываю реализацию UDF с ParamArray. Вот только интересно, есть ли ограничения на количество аргументов в этом самом ParamArray?
Код
Function СЧЁТУНИКЕСЛИМН(rngU As Range, ParamArray Conditions()) As Long
Dim cl As Range
Dim arrFlag() As Boolean
Dim I As Long
On Error Resume Next
With New Collection
For Each cl In rngU
ReDim arrFlag(Int(UBound(Conditions) / 2))
For I = LBound(Conditions) To UBound(Conditions) Step 2
If Cells(cl.Row, Conditions(I).Column).Value Like Conditions(I + 1) Then
arrFlag(Int(I / 2)) = True
End If
Next
If WorksheetFunction.And(arrFlag) = True Then
.Add cl, CStr(cl)
If Err = 0 Then
СЧЁТУНИКЕСЛИМН = СЧЁТУНИКЕСЛИМН + 1
Else
Err.Clear
End If
End If
Next
End With
End Function
Согласие есть продукт при полном непротивлении сторон