求各位大神用VBA实现以下功能！！！

35610101

求各位大神用VBA实现以下功能：在“录入表”中手工录入班主任到岗情况后，自动生成“汇总表”、“统计表”

shiruiqiang

说实话，不用信息化工具，如钉钉考勤啥的，你还要专门派1个人负责联系这么多班主任，长时间的话是否能坚持下来还是个未知数。

zxsea_7426

看看是不是这样的

leimingsen

做了一部分供参考！

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("录入表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    br = .Range("a3:d" & rs)
    sd = .[e2] & .[f2] & .[g2] & .[h2]
End With
With Sheets("汇总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r < 3 Or y < 2 Then MsgBox "汇总表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
    For j = 2 To y Step 3
        If Trim(ar(1, j)) <> "" Then
            If IsDate(ar(1, j)) Then
                zf = Format(ar(1, j), "m月d日")
                d(zf) = j
            End If
        End If
    Next j
    For i = 3 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            d(Trim(ar(i, 1))) = i
        End If
    Next i
    lh = d(sd)
    If lh <> "" Then
        For i = 2 To UBound(br)
            xh = d(Trim(br(i, 1)))
            If xh <> "" Then
                For j = 2 To 4
                    ar(xh, lh + j - 2) = br(i, j)
                Next j
            End If
        Next i
    End If
    .Range(.Cells(1, 1), .Cells(r, y)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

班主任到岗统计表.rar (26.57 KB, 下载次数: 6)

2023-5-18 18:01 上传

点击文件名下载附件

3190496160

个人之见：
代码是给你写了，但是，在网络这么发达的今天，不借助网络来实现学校管理，还在使用这种老旧的办法，到底有没有可操作性。

3190496160

Sub 统计()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("汇总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    y = .Cells(2, Columns.Count).End(xlToLeft).Column
    If r < 3 Or y < 2 Then MsgBox "汇总表为空！": End
    ar = .Range(.Cells(1, 1), .Cells(r, y))
End With
With Sheets("统计表")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    .Range("b2:c" & rs) = Empty
    br = .Range("a1:c" & rs)
    For i = 2 To UBound(br)
        If Trim(br(i, 1)) <> "" Then
            d(Trim(br(i, 1))) = i
        End If
    Next i
    For i = 3 To UBound(ar)
        If Trim(ar(i, 1)) <> "" Then
            xh = d(Trim(ar(i, 1)))
            If xh <> "" Then
                For j = 2 To y Step 1
                    If Trim(ar(i, j)) = 1 Then
                        br(xh, 2) = br(xh, 2) + 1
                    End If
                Next j
            End If
        End If
    Next i
    .Range("a1:c" & rs) = br
    For i = 2 To rs
        .Cells(i, 3) = Application.Rank(.Cells(i, 2), .Range("b2:b" & rs)) '''排名
    Next i
    .Range("a1:c" & rs).Sort .[b1], 2, , , , , , 1 '第一个数据，表示升序还是降序，2为升序，1为降序，第二个数据表示标题行数
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160