vsg-good, все условия сцепляете в одно, а потом как в Приёмах или по совету Багузина (через АГРЕГАТ)
UPD: сделал UDF'ки (НЕ ДЛЯ ЛИСТА) типа МАКСЕСЛИ/МИНЕСЛИ, а UDF МАКС/МИН оставил для примера, что принцип один и тот же (быстрее штатных в большинстве тестов)
UDF
Код
Function PRDX_Max(arr) As Boolean
Dim x, m#
m = -1E+100
For Each x In arr
If IsNumeric(x) Then
If --x > m Then m = x
End If
Next x
If m = -1E+100 Then Exit Function Else arr = m: PRDX_Max = True
End Function
'----------------------------------------------------------------------------------------------------
Function PRDX_MaxIf(tmpVal, rngFind As Range, rngGet As Range) As Boolean
Dim arrFind, arrGet, m#, i&
arrFind = rngFind.Value2
arrGet = rngGet.Value2
m = -1E+100
For i = LBound(arrFind, 1) To UBound(arrFind, 1)
If arrFind(i, 1) = tmpVal Then
If IsNumeric(arrGet(i, 1)) Then
If --arrGet(i, 1) > m Then m = arrGet(i, 1)
End If
End If
Next i
If m = -1E+100 Then Exit Function Else tmpVal = m: PRDX_MaxIf = True
End Function
'----------------------------------------------------------------------------------------------------
Function PRDX_Min(arr) As Boolean
Dim x, m#
m = 1E+100
For Each x In arr
If IsNumeric(x) Then
If x < m Then m = x
End If
Next x
If m = 1E+100 Then Exit Function Else arr = m: PRDX_Min = True
End Function
'----------------------------------------------------------------------------------------------------
Function PRDX_MinIf(tmpVal, rngFind As Range, rngGet As Range) As Boolean
Dim arrFind, arrGet, m#, i&
arrFind = rngFind.Value2
arrGet = rngGet.Value2
m = 1E+100
For i = LBound(arrFind, 1) To UBound(arrFind, 1)
If arrFind(i, 1) = tmpVal Then
If IsNumeric(arrGet(i, 1)) Then
If --arrGet(i, 1) < m Then m = arrGet(i, 1)
End If
End If
Next i
If m = 1E+100 Then Exit Function Else tmpVal = m: PRDX_MinIf = True
End Function
сейчас дотестирую UDF для листа и выложу
UPD2: (Функции листа для ОДНОГО критерия поиска)
Для работы нужны базовые UDF'ки «PRDX_MaxIf» и «PRDX_MinIf» (выше)
Код
Function PRDX_МаксЕсли(ЧтоИщем, ГдеИщемЗначение As Range, ГдеИщемМаксимум As Range)
Dim x
PRDX_МаксЕсли = "": x = ЧтоИщем
If PRDX_MaxIf(x, ГдеИщемЗначение, ГдеИщемМаксимум) Then PRDX_МаксЕсли = x
End Function
'-------------------------------------------------------------------------------------------
Function PRDX_МинЕсли(ЧтоИщем, ГдеИщемЗначение As Range, ГдеИщемМинимум As Range)
Dim x
PRDX_МинЕсли = "": x = ЧтоИщем
If PRDX_MinIf(x, ГдеИщемЗначение, ГдеИщемМинимум) Then PRDX_МинЕсли = x
End Function
UPD3: нашёл в закромах надстройку с кучей приблуд (в том числе МАКСЕСЛИ и МИНЕСЛИ), так что можно просто подключить её и не вставлять коды. Не тестировал, но на первый взгляд МАКСЕСЛИ и МИНЕСЛИ из надстройки гораздо медленнее тех, что выше…
Функции из надстройки
Код
Function МАКСЕСЛИ(критерий, диапазон_условия As Range, диапазон_значений As Range)
Dim arrCr(), arrV(), vF As Double, f As Boolean
arrCr = диапазон_условия.Value
arrV = диапазон_значений.Value
' проверка на многометрность
If (UBound(arrCr, 1) > 1 And UBound(arrCr, 2) > 1) Or (UBound(arrV, 1) > 1 And UBound(arrV, 2) > 1) Or _
UBound(arrCr, 1) <> UBound(arrV, 1) Or UBound(arrV, 2) <> UBound(arrCr, 2) Then
МАКСЕСЛИ = "#ССЫЛКА!"
Exit Function
End If
' Поиск значений для условия
Dim i As Long, ii As Long
For i = LBound(arrCr, 1) To UBound(arrCr, 1)
For ii = LBound(arrCr, 2) To UBound(arrCr, 2)
On Error Resume Next
If arrCr(i, ii) = критерий And TypeName(arrV(i, ii)) <> "Boolean" And TypeName(arrV(i, ii)) <> "String" Then
If Not f Then
vF = arrV(i, ii)
f = True
ElseIf vF < arrV(i, ii) Then
vF = arrV(i, ii)
End If
End If
On Error GoTo 0
Next ii
Next i
If Not f Then МАКСЕСЛИ = "#Н/Д": Exit Function
МАКСЕСЛИ = vF
End Function
Function МИНЕСЛИ(критерий, диапазон_условия As Range, диапазон_значений As Range)
Dim arrCr(), arrV(), vF As Double, f As Boolean
arrCr = диапазон_условия.Value
arrV = диапазон_значений.Value
' проверка на многометрность
If (UBound(arrCr, 1) > 1 And UBound(arrCr, 2) > 1) Or (UBound(arrV, 1) > 1 And UBound(arrV, 2) > 1) Or _
UBound(arrCr, 1) <> UBound(arrV, 1) Or UBound(arrV, 2) <> UBound(arrCr, 2) Then
МИНЕСЛИ = "#ССЫЛКА!"
Exit Function
End If
' Поиск значений для условия
Dim i As Long, ii As Long
For i = LBound(arrCr, 1) To UBound(arrCr, 1)
For ii = LBound(arrCr, 2) To UBound(arrCr, 2)
On Error Resume Next
If arrCr(i, ii) = критерий And TypeName(arrV(i, ii)) <> "Boolean" And TypeName(arrV(i, ii)) <> "String" Then
If Not f Then
vF = arrV(i, ii)
f = True
ElseIf vF > arrV(i, ii) Then
vF = arrV(i, ii)
End If
End If
On Error GoTo 0
Next ii
Next i
If Not f Then МИНЕСЛИ = "#Н/Д": Exit Function
МИНЕСЛИ = vF
End Function
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
ОлегИВаныч80, это никак к теме не относится. Создайте свою, а лучше поищите готовые темы по тэгам "двойное отрицание", "бинарное отрицание", "как преобразовать текст в число". Если кратко - это самый быстрый способ
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
ОлегИВаныч80, да уж угомонитесь наконец, или из цикла Вас только баном можно вывести? В рукаве у программиста всегда есть трюки и приемы позволяющие быстро и эффективно сделать те или иные операции, они дают результат и не всегда понятны, так как запись не очевидна, но последнее не делает код нерабочим. Если взять многие формулы листа, написанные знатоками, то они все нечитаемые, но прекрасно работают.
жаль, что удалили посты — пришлось на почте читать, а там неудобно Кстати, на мэйле тестируют новую оболочку - прикольная)))
P.S.: как по мне — всё после #3 под снос
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄