根据花名册信息在汇总表统计满足相关条件的个数

zhangjianiam

大神们，我有一个数据量较大的花名册，需要采取多条件汇总个数，想用VBA代码完成这个工作，研究了好半天，实在没弄出个门道来，望大神相助。谢谢！

半百

Sub TEST()
On Error Resume Next
Set D = CreateObject("scripting.dictionary")
Dim BRR(1 To 10)
ARR = Sheets("花名册").Range("A3").CurrentRegion
For I = 2 To UBound(ARR)
    Select Case ARR(I, 3)
    Case Is <= 20
        S = "20周岁及以下"
    Case 21
        S = "21周岁"
    Case 22
        S = "22周岁"
    Case 23
        S = "23周岁"
    Case 24
        S = "24周岁"
    Case Is >= 25
        S = "25周岁及以上"
    End Select
    If Not D.EXISTS(ARR(I, 4) & S) Then
        If ARR(I, 8) = "是" Then BRR(1) = 1
        If ARR(I, 7) = "是" Then BRR(10) = 1
        N = InStr("男病假女病假男事假女事假男在岗女在岗男脱岗女脱岗", ARR(I, 5) & ARR(I, 6))
        N = N / 3 + 2
        BRR(N) = 1
        D(ARR(I, 4) & S) = BRR
        Erase BRR
    Else
        B = D(ARR(I, 4) & S)
        If ARR(I, 8) = "是" Then B(1) = B(1) + 1
        If ARR(I, 7) = "是" Then B(10) = B(10) + 1
        N = InStr("男病假女病假男事假女事假男在岗女在岗男脱岗女脱岗", ARR(I, 5) & ARR(I, 6))
        N = N / 3 + 2
        B(N) = B(N) + 1
        D(ARR(I, 4) & S) = B
    End If
Next
With Sheets("汇总表")
    R = .Cells(Rows.Count, 1).End(xlUp).Row
    CRR = .Range("A6:L" & R)
    For J = 1 To R - 5
        S = CRR(J, 1) & CRR(J, 2)
        For K = 1 To 10
            CRR(J, K + 2) = D(S)(K)
        Next
    Next
    .Range("A6:L" & R) = CRR
End With
End Sub

zhangjianiam

半百 发表于 2019-8-8 09:30
Sub TEST()
On Error Resume Next
Set D = CreateObject("scripting.dictionary")

刚上来才看到，谢谢了。弄下来运行下，好好学习