有偿请老师们帮忙编写VBA，只要是用来数据汇总，加快速度

晴天一线

请老师帮忙编写一vba，加快工作速度。详细请看以下附件

3190496160

Sub 宿舍统计()
Dim ar As Variant
Dim br(), brr()
Dim d As Object, dc As Object, dic As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
ar = Sheets("在宿").[a1].CurrentRegion
For i = 3 To UBound(ar)
    If Trim(ar(i, 5)) <> "" Then
        zf = Trim(ar(i, 5))
        d(zf) = d(zf) + 1
    End If
Next i
ReDim br(1 To UBound(ar), 1 To 11)
For Each k In d.keys
    n = n + 1
    sn = "": sv = ""
    ns = 0: vs = 0
    dc.RemoveAll: dic.RemoveAll
    For i = 3 To UBound(ar)
        zf_1 = Trim(ar(i, 5))
        If zf_1 = k Then
            If Trim(ar(i, 4)) = "男" Then
                ns = ns + 1
                If Not dc.exists(Trim(ar(i, 9))) Then
                    If sn = "" Then
                        sn = ar(i, 9)
                    Else
                        sn = sn & "、" & ar(i, 9)
                    End If
                    dc(Trim(ar(i, 9))) = ""
                End If
            End If
            If Trim(ar(i, 4)) = "女" Then
                vs = vs + 1
                If Not dic.exists(Trim(ar(i, 9))) Then
                    If sv = "" Then
                        sv = ar(i, 9)
                    Else
                        sv = sv & "、" & ar(i, 9)
                    End If
                    dic(Trim(ar(i, 9))) = ""
                End If
            End If
            
        End If
    Next i
    If sn <> "" Then
        rr = Split(sn, "、")
        br(n, 1) = k
        br(n, 2) = ns
        br(n, 3) = UBound(rr) + 1
        br(n, 4) = (UBound(rr) + 1) * 8 - ns
        If br(n, 4) > 0 Then
            br(n, 5) = rr(UBound(rr))
        Else
            br(n, 5) = ""
        End If
        br(n, 6) = sn
    End If
    If sv <> "" Then
        rr = Split(sv, "、")
        br(n, 7) = vs
        br(n, 8) = UBound(rr) + 1
        br(n, 9) = (UBound(rr) + 1) * 8 - vs
        If br(n, 9) > 0 Then
            br(n, 10) = rr(UBound(rr))
        Else
            br(n, 10) = ""
        End If
        br(n, 11) = sv
    End If
Next k
With Sheets("宿舍数据汇总")
    .UsedRange.Offset(3) = Empty
    .[a4].Resize(n, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub

3190496160

安排表数据.rar (464.08 KB, 下载次数: 166)

2021-3-8 10:18 上传

点击文件名下载附件

3190496160

一个初稿，先看看，如果还有问题，可以加qq具体沟通

清风竹-

请看附件。

晴天一线

清风竹- 发表于 2021-3-8 15:08
请看附件。

很好用，谢谢

boy8199

好像 以前又这么 一个 帖子,当时 我提出方案  让 改表格设计.

wang-way

做个记号 改天把自己单位的处理一下