ExcelVBA通用统计任意多条件多项目个数和汇总

    '使用方法，□处等待你的输入
    '1.工作表名为“通用统计”
    '第一行：工作表,□，数据区域，□
    '第二行：条件，□，□，□。。。
    '第三行：项目，□，□，□。。。
Sub 通用统计()
    Dim karr, darr, res
    With Worksheets("通用统计")
        .Range("A4").Resize(1000, 200) = ""
        A2Col = .Range("XFD2").End(xlToLeft).Column
        A3Col = .Range("XFD3").End(xlToLeft).Column
        arr = .Range("A2").Resize(1, A2Col).Value
        brr = .Range("A3").Resize(1, A3Col).Value
        .Range("A4").Resize(1, A2Col) = .Range("A2").Resize(1, A2Col).Value
        .Range("A4").Offset(0, A2Col).Resize(1, A3Col) = .Range("A3").Resize(1, A3Col).Value
        .Range("A4") = "序号"
        .Range("A4").Offset(0, A2Col) = "人数"
        shtName = .Range("B1").Value
        dataRng = .Range("D1").Value
        If Not SheetExists(shtName) Then MsgBox "工作表设置有误": Exit Sub
    End With
    With Worksheets(shtName)
        crr = .Range(dataRng)
        title_arr = Application.Index(crr, 1, 0)
        ReDim karr(UBound(arr, 2) - 2)
        ReDim darr(UBound(brr, 2) - 2)
        m = 0
        For j = 0 To UBound(karr)
            karr(m) = Application.WorksheetFunction.Match(arr(1, j + 2), title_arr, 0)
            m = m + 1
        Next
        m = 0
        For j = 0 To UBound(darr)
            darr(m) = Application.WorksheetFunction.Match(brr(1, j + 2), title_arr, 0)
            m = m + 1
        Next
    End With
    res = conSumArr(crr, karr, darr)
    With Worksheets("通用统计")
        .Range("B5").Resize(UBound(res, 1), UBound(res, 2)) = res
    End With
End Sub
    '任意多条件、任意多项目统计个数、汇总和，返回数组，使用方法：res=conSumArr(data_arr, conArray, itemArray)
    '输出.Range("B5").Resize(UBound(res, 1), UBound(res, 2)) = res
    '参数1：data_arr-含有标题行1行的数组
    '参数2：conArray-一维数组Array(多条件)
    '参数3：itemArray-一维数组Array(多个要统计项目)
Function conSumArr(data_arr, conArray, itemArray)
    Dim t_d As Object, key_arr, mydata_arr, i%, j%, m%, dilimi As String, aCount%
    delimi = "|"
    Set t_d = CreateObject("scripting.dictionary")
    ReDim key_arr(1 To UBound(data_arr, 1), 1 To UBound(conArray) + 1)
    For i = 2 To UBound(data_arr, 1)
        j = 1
        For Each con In conArray
            key_arr(i, j) = data_arr(i, con)
            j = j + 1
        Next
        s = Join(Application.Index(key_arr, i, 0), delimi)
        If Not t_d.exists(s) Then
            m = m + 1
            t_d(s) = m
        End If
    Next i
    aCount = t_d.Count
    ReDim mydata_arr(1 To aCount, 1 To UBound(itemArray) + 2)
    For i = 2 To UBound(data_arr, 1)
        s = Join(Application.Index(key_arr, i, 0), delimi)
        n = t_d(s)
        mydata_arr(n, 1) = mydata_arr(n, 1) + 1
        j = 2
        For Each itemA In itemArray
            mydata_arr(n, j) = mydata_arr(n, j) + data_arr(i, itemA)
            j = j + 1
        Next
    Next i
    ReDim result(1 To aCount, 1 To UBound(key_arr, 2) + UBound(mydata_arr, 2))
    '    For m = 1 To UBound(result, 1)
    For j = 1 To UBound(result, 2)
        If j <= UBound(key_arr, 2) Then
            result(m, j) = Split(t_d.keys()(m - 1), delimi)(j - 1)
        Else
            result(m, j) = mydata_arr(m, j - UBound(key_arr, 2))
        End If
    Next j
    Next m
    conSumArr = result
End Function
    '检测工作表是否存在
Function SheetExists(sname) As Boolean
    Dim x As Object
    On Error Resume Next
    Set x = ActiveWorkbook.Sheets(sname)
    If Err = 0 Then
        SheetExists = True
    Else
        SheetExists = False
    End If
End Function