Excel 如何在VBA中编写克隆SUMIF函数？_Excel_Excel Formula

Excel 如何在VBA中编写克隆SUMIF函数？

excel excel-formula

Excel 如何在VBA中编写克隆SUMIF函数？,excel,excel-formula,Excel,Excel Formula,最近，为了消除我的好奇心，我试图了解如果原生Excel函数是用VBA语言编写的，它们将如何工作。我正在研究的一个这样的函数是SUMIF 只要条件是“等于”=运算符，我就能够编写代码来复制sum的精确功能。如何更改代码以适应其他操作符，例如=，您可以在VBA中使用许多工作表函数。假设我们的数据如下：我们加入了一个标准模块： Public Function Vsumif(crrange As Range, crit As String, which As Range) With App

最近，为了消除我的好奇心，我试图了解如果原生Excel函数是用VBA语言编写的，它们将如何工作。我正在研究的一个这样的函数是

SUMIF

只要条件是“等于”

运算符，我就能够编写代码来复制sum的精确功能。如何更改代码以适应其他操作符，例如

，

您可以在VBA中使用许多工作表函数。假设我们的数据如下：

我们加入了一个标准模块：
Public Function Vsumif(crrange As Range, crit As String, which As Range)
    With Application.WorksheetFunction
        Vsumif = .SumIf(crrange, crit, which)
    End With
End Function

然后在某些单元格中输入：
=vsumif(A:A,">=10",C:C)

它将产生正确的结果
要在子对象中使用UDF（）：
Sub demo()
    Dim x As Variant

    x = Vsumif(Range("A:A"), ">=10", Range("C:C"))
    MsgBox x
End Sub

退房
Function test_sumif(c_a As Range, c_b As String, c_c As Range)
n = 1

For Each r In c_a

If Application.Evaluate(r.Value & c_b) Then
 test_sumif = test_sumif + c_c(n, 1).Value
End If

n = n + 1
Next

End Function

它与原始sumif函数的功能非常接近。但未处理可选的sumrange部件。
这是一种可能性。它没有按照您的要求使用Evaluate
Function SUMIF_VBA(Crit_Rng As Range, Condition_U As Variant, Sum_Rng As Range)

R_Offset = Sum_Rng.Row - Crit_Rng.Row
C_Offset = Sum_Rng.Column - Crit_Rng.Column

SUMIF_VBA = 0

Call ParseCondition(Condition_U, Cond_out, Criteria_out)
For Each Cell In Crit_Rng

SumThis = False
Select Case Cond_out
    Case 3
        If Cell.Value = Criteria_out Then
            SumThis = True
        End If
    Case 5
        If Cell.Value > Criteria_out Then
            SumThis = True
        End If
    Case 7
        If Cell.Value < Criteria_out Then
            SumThis = True
        End If
    Case 8
        If Cell.Value >= Criteria_out Then
            SumThis = True
        End If
    Case 10
        If Cell.Value <= Criteria_out Then
            SumThis = True
        End If
    Case 12
        If Cell.Value <> Criteria_out Then
            SumThis = True
        End If
End Select

If SumThis Then
    SUMIF_VBA = SUMIF_VBA + Cell.Offset(R_Offset, C_Offset).Value
End If

Next Cell

End Function

Private Sub ParseCondition(Cond_in, Cond_out, Criteria_out)

    '* Evaluate the condition and set a unique number on each condition
    Cond_out = 0
    If InStr(Cond_in, "=") Then
      Cond_out = Cond_out + 3
    End If

    If InStr(Cond_in, ">") Then
      Cond_out = Cond_out + 5
    End If

    If InStr(Cond_in, "<") Then
      Cond_out = Cond_out + 7
    End If

    Set SDI = CreateObject("VBScript.RegExp")
    SDI.Pattern = "\d+"  '* keep the number only
    Set Num_out = SDI.Execute(Cond_in)
    Criteria_out = Val(Num_out(0))


End Sub


函数SUMIF\U VBA（临界值作为范围，条件作为变量，总和作为范围）
R_Offset=总和行-临界行
C_Offset=求和列-临界列
SUMIF_VBA=0
调用ParseCondition（条件、条件、条件）
对于临界值中的每个单元格
SumThis=False
选择案例条件
案例3
如果Cell.Value=Criteria\u out，则
这是真的吗
如果结束
案例5
如果Cell.Value>条件_out，则
这是真的吗
如果结束
案例7
如果单元格值<标准值，则
这是真的吗
如果结束
案例8
如果Cell.Value>=条件\u out，则
这是真的吗
如果结束
案例10
如果Cell.Value这里有一些想法：
'This function returns the filtered array to the caller, so that it may sum, concat, average or whatever
Private Function GetFilteredArray(leftArgRange As Range, condition As Variant, Optional sumRange As Range) As Variant()
    Dim sumArray() As Variant, leftArgArray() As Variant

    If leftArgRange.Cells.CountLarge > 1 Then
        leftArgArray = Intersect(leftArgRange.Worksheet.UsedRange, leftArgRange).Value2
    ElseIf leftArgRange.Cells.Count = 1 Then
        leftArgArray = Array(leftArgRange.Cells(1, 1).Value2)
    Else
        Exit Function   'return empty array
    End If

    If sumRange Is Nothing Then
        sumArray = leftArgArray
    Else
        sumArray = Intersect(sumRange.Worksheet.UsedRange, sumRange).Value2
    End If

    Dim filteredArr() As Variant
    ReDim filteredArr(0 To leftArgRange.Cells.Count - 1)

    Dim v As Variant
    Dim i As Long, j As Long, filteredCount As Long

    For i = LBound(leftArgArray) To UBound(leftArgArray)
        For j = LBound(leftArgArray, 2) To UBound(leftArgArray, 2)
            If Compare(leftArgArray(i, j), condition) Then
                filteredArr(filteredCount) = sumArray(i, j)
                filteredCount = filteredCount + 1
            End If
        Next j
    Next i

    If filteredCount > 0 Then
        ReDim Preserve filteredArr(0 To filteredCount - 1)
        GetFilteredArray = filteredArr
    End If

End Function

Private Function Compare(leftArg As Variant, condition As Variant) As Boolean
    On Error Resume Next
    Dim rightArg As Variant
    If VarType(condition) = vbString Then
        'parse String
        If condition Like ">=*" Then
            rightArg = Mid(condition, 3)
            Compare = leftArg >= IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like "<=*" Then
            rightArg = Mid(condition, 3)
            Compare = leftArg <= IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like ">*" Then
            rightArg = Mid(condition, 2)
            Compare = leftArg > IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like "<*" Then
            rightArg = Mid(condition, 2)
            Compare = leftArg < IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like "**LIKE**" Then
            rightArg = Mid(condition, 7)
            Compare = InStr(1, leftArg, rightArg, vbTextCompare) > 0
        Else
            'assume equals
            rightArg = condition
            Compare = leftArg = rightArg
        End If
    Else
        'assume other primitive/struct such as Date, numeric, boolean etc
        rightArg = condition
        Compare = leftArg = rightArg
    End If

End Function

使用Evaluate语句，看看它是否适合您。最好将功能分为两部分编写—一部分采用if条件，最后一部分可以是结果集上的聚合函数。这将允许更容易地使用其他函数，即Averageif、medianif等。此外，我不会在函数中使用耦合逻辑（无偏移-根据输入范围自身的优点将其视为数据数组并引用它们）。此外，为什么不为条件参数编写解析器，以便识别和使用各种输入？谢谢回复。我实际上要寻找的是这背后的代码，而不使用任何工作表函数。正如我之前所说，这只是出于好奇。我刚刚开始学习编程，一个重要的部分是能够理解如何构造代码以获得结果。因此，我想要一个完全从VBA角度的解决方案，而不需要任何工作表函数的帮助。如果你能帮我，我会非常感激的。嗨。谢谢你的回复<代码>应用程序。Evaluate
将在存在“>=”或任何其他逻辑运算符的位置工作。但是，如果没有，它将不起作用。但这可以通过使用InStr
函数来识别何时有操作员，何时没有操作员来解决。然而，更大的问题是Application.Evaluate不能比较两个字符串。因为B>A不是应用程序的东西。评估是能够比较的。而苏米夫是这样做的。谢谢你的回复。你能帮我理解这些代码行的意思吗Set SDI=CreateObject（“VBScript.RegExp”）SDI.Pattern=“\d+”*只保留数字Set Num_out=SDI.Execute（Cond_in）Criteria_out=Val（Num_out（0））这称为正则表达式。许多现代语言都有这个功能。正则表达式使用该模式来解析字符串。在本例中，“\d+”从字符串返回数字，但它以数据结构和文本文本形式返回。因此，Num_out（0）获取SDI.Execute语句返回的值，Val将其转换为数字。
Function SUMIF_VBA(Crit_Rng As Range, Condition_U As Variant, Sum_Rng As Range)

R_Offset = Sum_Rng.Row - Crit_Rng.Row
C_Offset = Sum_Rng.Column - Crit_Rng.Column

SUMIF_VBA = 0

Call ParseCondition(Condition_U, Cond_out, Criteria_out)
For Each Cell In Crit_Rng

SumThis = False
Select Case Cond_out
    Case 3
        If Cell.Value = Criteria_out Then
            SumThis = True
        End If
    Case 5
        If Cell.Value > Criteria_out Then
            SumThis = True
        End If
    Case 7
        If Cell.Value < Criteria_out Then
            SumThis = True
        End If
    Case 8
        If Cell.Value >= Criteria_out Then
            SumThis = True
        End If
    Case 10
        If Cell.Value <= Criteria_out Then
            SumThis = True
        End If
    Case 12
        If Cell.Value <> Criteria_out Then
            SumThis = True
        End If
End Select

If SumThis Then
    SUMIF_VBA = SUMIF_VBA + Cell.Offset(R_Offset, C_Offset).Value
End If

Next Cell

End Function

Private Sub ParseCondition(Cond_in, Cond_out, Criteria_out)

    '* Evaluate the condition and set a unique number on each condition
    Cond_out = 0
    If InStr(Cond_in, "=") Then
      Cond_out = Cond_out + 3
    End If

    If InStr(Cond_in, ">") Then
      Cond_out = Cond_out + 5
    End If

    If InStr(Cond_in, "<") Then
      Cond_out = Cond_out + 7
    End If

    Set SDI = CreateObject("VBScript.RegExp")
    SDI.Pattern = "\d+"  '* keep the number only
    Set Num_out = SDI.Execute(Cond_in)
    Criteria_out = Val(Num_out(0))


End Sub


'This function returns the filtered array to the caller, so that it may sum, concat, average or whatever
Private Function GetFilteredArray(leftArgRange As Range, condition As Variant, Optional sumRange As Range) As Variant()
    Dim sumArray() As Variant, leftArgArray() As Variant

    If leftArgRange.Cells.CountLarge > 1 Then
        leftArgArray = Intersect(leftArgRange.Worksheet.UsedRange, leftArgRange).Value2
    ElseIf leftArgRange.Cells.Count = 1 Then
        leftArgArray = Array(leftArgRange.Cells(1, 1).Value2)
    Else
        Exit Function   'return empty array
    End If

    If sumRange Is Nothing Then
        sumArray = leftArgArray
    Else
        sumArray = Intersect(sumRange.Worksheet.UsedRange, sumRange).Value2
    End If

    Dim filteredArr() As Variant
    ReDim filteredArr(0 To leftArgRange.Cells.Count - 1)

    Dim v As Variant
    Dim i As Long, j As Long, filteredCount As Long

    For i = LBound(leftArgArray) To UBound(leftArgArray)
        For j = LBound(leftArgArray, 2) To UBound(leftArgArray, 2)
            If Compare(leftArgArray(i, j), condition) Then
                filteredArr(filteredCount) = sumArray(i, j)
                filteredCount = filteredCount + 1
            End If
        Next j
    Next i

    If filteredCount > 0 Then
        ReDim Preserve filteredArr(0 To filteredCount - 1)
        GetFilteredArray = filteredArr
    End If

End Function

Private Function Compare(leftArg As Variant, condition As Variant) As Boolean
    On Error Resume Next
    Dim rightArg As Variant
    If VarType(condition) = vbString Then
        'parse String
        If condition Like ">=*" Then
            rightArg = Mid(condition, 3)
            Compare = leftArg >= IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like "<=*" Then
            rightArg = Mid(condition, 3)
            Compare = leftArg <= IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like ">*" Then
            rightArg = Mid(condition, 2)
            Compare = leftArg > IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like "<*" Then
            rightArg = Mid(condition, 2)
            Compare = leftArg < IIf(IsNumeric(rightArg), CDec(rightArg), rightArg)
        ElseIf condition Like "**LIKE**" Then
            rightArg = Mid(condition, 7)
            Compare = InStr(1, leftArg, rightArg, vbTextCompare) > 0
        Else
            'assume equals
            rightArg = condition
            Compare = leftArg = rightArg
        End If
    Else
        'assume other primitive/struct such as Date, numeric, boolean etc
        rightArg = condition
        Compare = leftArg = rightArg
    End If

End Function

Public Function VBA_SUMIF(leftArgRange As Range, condition As Variant, Optional sumRange As Range) As Double
    Dim filteredArr() As Variant
    filteredArr = GetFilteredArray(leftArgRange, condition, sumRange)

    On Error Resume Next
    Dim i As Long, total As Double
    For i = LBound(filteredArr) To UBound(filteredArr)
        total = total + filteredArr(i)
    Next i

    VBA_SUMIF = total
End Function

Public Function VBA_CONCATIF(leftArgRange As Range, condition As Variant, Optional sumRange As Range, Optional delimiter As String = "") As String
    Dim filteredArr() As Variant
    filteredArr = GetFilteredArray(leftArgRange, condition, sumRange)

    VBA_CONCATIF = Join(filteredArr, delimiter)
End Function

Public Function VBA_COUNTIF(leftArgRange As Range, condition As Variant) As Long
    Dim filteredArr() As Variant
    filteredArr = GetFilteredArray(leftArgRange, condition)

    On Error Resume Next
    VBA_COUNTIF = UBound(filteredArr) - LBound(filteredArr) + 1
End Function