ExcelVBA-自定义函数MultiConTosum用于多条件求和

'传入一维数组和标题，返回标题在数组中的位置
Function StrToId(inarr, s)

    Dim t_m%

    On Error Resume Next

    t_m = Application.WorksheetFunction.Match(s, inarr, 0)

    If Err = 0 Then

        StrToId = t_m

    Else

        StrToId = 0

    End If

    On Error GoTo 0

End Function

'=MultiConTosum(数据全区域,条件标题区域,求和标题,条件区域)

'例：=MultiConTosum($A$1:$J$13,$B$21:$C$21,D$21,$B22:$C22)

'1.数据全区域----绝对引用区域第一列第一行开始（一定含标题行）

'2.条件标题区域--绝对引用条件标题

'3.求和标题------列绝对引用求和标题（一个单元格）

'4.条件区域------行绝对引用

Function MultiConTosum(dataRng As range, conTitleRng As range, sumRng As range, conRng As range)

    Dim data_arr, data_arr1, con_arr, t_Array()

    Dim t_num, y, k As Integer, sumStr As String, rr As range, gotoNext As Boolean, get_Col As Integer

    Dim dic As Object

    Set dic = CreateObject("scripting.dictionary")

    data_arr = dataRng.Value

    data_arr1 = Application.Index(data_arr, 1, 0)

    con_arr = conRng.Value

    t_num = Application.WorksheetFunction.CountA(conTitleRng)

    k = 1

    gotoNext = True

    If t_num > 0 Then

        ReDim t_Array(1 To t_num)

        sjoin = Join(Application.Index(con_arr, 1, 0), "")

        dic(sjoin) = 0

        For Each rr In conTitleRng

            If rr <> "" Then

                t_Array(k) = StrToId(data_arr1, rr.Value)

                k = k + 1

            End If

        Next

    Else

        gotoNext = False

    End If

    get_Col = StrToId(data_arr1, sumRng.Value)

    If get_Col = 0 Then gotoNext = False

    If gotoNext = False Then

        MultiConTosum = 0

    Else

        For k = 2 To UBound(data_arr)

            s = Join(Application.Index(data_arr, k, t_Array), "")

            If dic.exists(s) Then dic(s) = dic(s) + data_arr(k, get_Col)

        Next k

        MultiConTosum = dic(sjoin)

    End If

End Function