为MAXifs创建VBA代码 [英] Create VBA code for MAXifs

问题描述

我已尝试将另一篇文章中的代码改编为更容易理解的内容.运行代码时，此行仍然出现错误类型不匹配": w(k)= z(i，1).有人对此错误有任何见解吗?

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?

我的代码

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            

推荐答案

开始编写代码后，一个限制是您只能使用2种条件.我决定进一步使用此代码，以不限制MaxIfs函数的条件数量.请在此处查看代码:

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

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

This code allows 1 to multiple conditions.

此代码是参考Hans V在Eileen's Lounge张贴的多个代码开发的.

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

Diedrich

这篇关于为MAXifs创建VBA代码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！