为 MAXifs 创建 VBA 代码

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

开始编写代码后，有一个限制是您仅限于 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

此代码允许 1 到多个条件。

此代码是参考 Hans V 在 Eileen's Lounge 发布的多个代码开发的。

戴德里希

Answer 2

由于您有兴趣返回一些值中的最大值以在

MaxRange

范围之间进行选择，那么您可以仅循环遍历其 numeric 值，并仅检查

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 3

我改进了 Diedrich 解决方案：

    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 InStr(CStr(Criteria(c + 1)), "<>") > 0 Then
                If Evaluate(CStr(Criteria(c).Cells(i).Value) + CStr(Criteria(c + 1))) <> True Then
                    f = False
                End If
            ElseIf 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