Create VBA code for MAXifs

问题

I have tried to adapt code from another post into something easier for me to understand. When running the code, I still get an error "Type mismatch" for this line: w(k) = z(i, 1). Does anyone have any insight into this error?

My Code

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            

回答1:

After getting to code to work, a limitation was that you are restricted to 2 conditions. I decided to take this code further to not restrict the number of conditions for the MaxIfs function. Please see the code here:

    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

This code allows 1 to multiple conditions.

This code was developed with reference to multiple code posted by Hans V over at Eileen's Lounge.

Diedrich

回答2:

since you're interested in returning a maximum value out of some to choose between MaxRange range, then you could loop through its numeric values only and check conditions in corresponding cells of Lookup_Range1 and Lookup_Range2 only, like follows:

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

where I also gave more meaningful names to variables

来源：https://stackoverflow.com/questions/41031524/create-vba-code-for-maxifs