Создать код VBA для MAXifs

Question

Я попытался адаптировать код из другого сообщения во что-то более легкое для понимания. При запуске кода я все равно получаю сообщение об ошибке «Тип несоответствия» для этой строки: w(k) = z(i, 1). Кто-нибудь имеет представление об этой ошибке?

Моего код

Option Base 1 

Function MaxIf(MaxRange As Range, Lookup_Range1 As Range, Var_Range1 As Variant, _ 
       Lookup_Range2 As Range, Var_Range2 As Variant) As Variant 

    Dim x() As Variant, y() As Variant, z() As Variant, w() As Long 
    Dim i As Long 
    Dim Constraint1 As Variant, Constraint2 As Variant, k As Long 

    i = 1 
    k = 0 
    Constraint1 = Var_Range1 
    Constraint2 = Var_Range2 
    x = Lookup_Range1 
    y = Lookup_Range2 
    z = MaxRange 

    For i = 1 To Lookup_Range1.Rows.Count 
     If x(i, 1) = Var_Range1 Then 
      If y(i, 1) = Var_Range2 Then 
       k = k + 1 
       ReDim Preserve w(k) 
       w(k) = z(i, 1) 
      End If 
     End If 
    Next i 
    MaxIf = Application.Max(w) 

End Function    

Answer 1

, поскольку вы заинтересованы в возвращении максимального значения из некоторых выбирать между MaxRange диапазоном, то вы можете перебрать его числовых только значения и проверки условий в соответствующем клетки Lookup_Range1 и Lookup_Range2 только, как следует:

Function MaxIF(MaxRange As Range, Lookup_Range1 As Range, Var_Range1 As Variant, _ 
       Lookup_Range2 As Range, Var_Range2 As Variant) As Variant 

    Dim LU1 As Variant, LU2 As Variant 
    Dim founds As Long 
    Dim cell As Range 

    LU1 = Lookup_Range1.Value2 '<--| store Lookup_Range1 values 
    LU2 = Lookup_Range2.Value2 '<--| store Lookup_Range2 values 

    ReDim ValuesForMax(1 To MaxRange.Rows.count) As Long '<--| initialize ValuesForMax to its maximum possible size 
    For Each cell In MaxRange.Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers) 
     If LU1(cell.row, 1) = Var_Range1 Then '<--| check 'Lookup_Range1' value in corresponding row of current 'MaxRange' cell 
      If LU2(cell.row, 1) = Var_Range2 Then '<--| check 'Lookup_Range2' value in corresponding row of current 'MaxRange' cell 
       founds = founds + 1 
       ValuesForMax(founds) = CLng(cell) '<--| store current 'MaxRange' cell 
      End If 
     End If 
    Next cell 
    ReDim Preserve ValuesForMax(1 To founds) '<--| resize ValuesForMax to its actual values number 
    MaxIF = Application.max(ValuesForMax) 
End Function 

где я дал более значимые имена переменным

Answer 2

После получения кода для работы было ограничено, что вы ограничены двумя условиями. Я решил продолжить этот код, чтобы не ограничивать количество условий для функции MaxIfs. См. Здесь код:

Function MaxIfs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant 
    Dim n As Long 
    Dim i As Long 
    Dim c As Long 
    Dim f As Boolean 
    Dim w() As Long 
    Dim k As Long 
    Dim z As Variant 

    'Error if less than 1 criteria 
    On Error GoTo ErrHandler 
    n = UBound(Criteria) 
    If n < 1 Then 
     'too few criteria 
     GoTo ErrHandler 
    End If 

    'Define k 
    k = 0 

    'Loop through cells of max range 
    For i = 1 To MaxRange.Count 

    'Start by assuming there is a match 
    f = True 

     'Loop through conditions 
     For c = 0 To n - 1 Step 2 

      'Does cell in criteria range match condition? 
      If Criteria(c).Cells(i).Value <> Criteria(c + 1) Then 
       f = False 
      End If 

     Next c 

     'Define z 
     z = MaxRange 

     'Were all criteria satisfied? 
     If f Then 
      k = k + 1 
      ReDim Preserve w(k) 
      w(k) = z(i, 1) 
     End If 

    Next i 

    MaxIfs = Application.Max(w) 

    Exit Function 
    ErrHandler: 
    MaxIfs = CVErr(xlErrValue) 

End Function 

Этот код позволяет использовать несколько условий.

Этот код был разработан с учетом большого количества кода, отправленного Хансом В. в Lounge Lounge.

Diedrich