заполняю таблицу где необходимо подтянуть макс значение по критерию
Критерий
Макс значение
1
2
3
…
n
из свода данных вида
Диапазон критериев
Столбец со значением (1)
Столбец со значением (2)
…
…
…
Хотел воспользоваться функцией максесли (maxifs) но выяснилось, что работаю на версии 2013.
думаю, что в 2016 написал бы формулу в стиле max(maxifs(столбец со значением 1; диапазон критериев; критерий 1);maxifs(столбец со значением 2; диапазон критериев; критерий 1).
в 2013 версии в голову никакой замены не приходит.
Function МАКСЕСЛИМН(rng As Range, ParamArray Cond())
Dim arr(), arrFlag(), arrCond(), arrMax()
Dim I&, J&, N&
On Error Resume Next
arr = Intersect(rng.Parent.UsedRange, rng).Value
For I = LBound(arr) To UBound(arr)
ReDim arrFlag(Int(UBound(Cond) / 2))
For J = LBound(Cond) To UBound(Cond) Step 2
If IsObject(Cond(J)) Then arrCond = Intersect(Cond(J).Parent.UsedRange, Cond(J)).Value
If IsNumeric(arrCond(I, 1)) And Cond(J + 1) Like "[><=]" Then
If Application.Evaluate(Replace(arrCond(I, 1), ",", ".") & Cond(J + 1)) Then arrFlag(Int(J / 2)) = True
Else
If arrCond(I, 1) Like Cond(J + 1) Then arrFlag(Int(J / 2)) = True
End If
Next
If WorksheetFunction.And(arrFlag) = True Then
If Err = 0 Then
ReDim Preserve arrMax(N)
arrMax(N) = arr(I, 1)
N = N + 1
Else
Err.Clear
End If
End If
Next
МАКСЕСЛИМН = Application.Max(arrMax)
End Function
UDF получилась не из быстрых. Обычный макрос. Нажать на MAX
Код
Sub MAXIFS()
Dim arrCond(), arr(), iArr(), I&, J&
Dim dic As Object
With Worksheets("таблица")
arrCond = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
With Worksheets("Sheet12")
arr = .Range("B3:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
On Error Resume Next
Set dic = CreateObject("Scripting.Dictionary")
For I = 1 To UBound(arr)
Erase iArr
For J = 0 To 1
If arr(I, J + 2) <> Empty Then
ReDim Preserve iArr(J)
iArr(J) = arr(I, J + 2)
End If
Next
dic.Add CStr(arr(I, 1)), iArr
If Err <> 0 Then
iArr = dic(CStr(arr(I, 1)))
For J = 0 To 1
If arr(I, J + 2) <> Empty Then
ReDim Preserve iArr(UBound(iArr) + 1)
iArr(UBound(iArr)) = arr(I, J + 2)
End If
Next
dic(CStr(arr(I, 1))) = iArr
Err.Clear
End If
Next
ReDim arrMax(1 To UBound(arrCond), 0)
For I = 1 To UBound(arrCond)
arrMax(I, 0) = IIf(dic.Exists(CStr(arrCond(I, 1))), Application.Max(dic(CStr(arrCond(I, 1)))), Empty)
Next
With Worksheets("таблица").Range("D4").Resize(UBound(arrMax))
.ClearContents
.Value = arrMax
End With
End Sub
При условии что нет отрицательных значенй. на выбор: =AGGREGATE(14;6;(B4=Sheet12!$B$3:$B$1897)*Sheet12!$C$3:$D$1897;1) Массивные {} =LARGE((B4=Sheet12!$B$3:$B$1897)*Sheet12!$C$3:$D$1897;1) =MAX((B4=Sheet12!$B$3:$B$1897)*Sheet12!$C$3:$D$1897)