为 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

我还给变量取了更有意义的名字