把汇总表的数据填入到班级分表中

熊文来

感谢走过路过的大师，帮忙看看我的文件。谢谢！



1.填写排查时间：
2.填写班主任姓名：
3.每个班级按照2页进行填入。文件里已经设置了打印标题。因为排版问题，第1页填入前面31个学生的数据，第2页填写剩余学生的数据。
4.在第2页最后一行需要统计各项目的总数。
5.第2页还有一条备注。
6.每个班生成独立的工作簿，并用班级作为文件名
7.因为最后还要打印纸质文件，正反面打印。所以希望能添加打印选项，打印第1页还是第2页。
麻烦大家帮忙看看 谢谢！

3190496160

咋又来这个问题了？类似的问题，要学会自己融会贯通呀

3190496160

Sub 分班()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim d As Object, dc As Object
Dim arr(), brr()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("汇总表")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 3 Then MsgBox "数据源为空！": End
    ar = .Range("a1:n" & r)
    rs = .Cells(Rows.Count, 19).End(xlUp).Row
    If rs < 3 Then MsgBox "班主任信息为空！": End
    br = .Range("s1:t" & r)
    rq = Format(.[q1], "yyyy年m月d日")
End With
For i = 2 To UBound(br)
    If Trim(br(i, 1)) <> "" Then
        dc(Trim(br(i, 1))) = br(i, 2)
    End If
Next i
For i = 3 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(Trim(ar(i, 1))) = ""
    End If
Next i
For Each k In d.keys
    n = 0: m = 0
    ReDim arr(1 To UBound(ar), 1 To UBound(ar, 2))
    ReDim brr(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 3 To UBound(ar)
        If Trim(ar(i, 1)) = k Then
            n = n + 1
            If n <= 31 Then
                For j = 1 To UBound(ar, 2)
                    arr(n, j) = ar(i, j)
                Next j
            Else
                m = m + 1
                For j = 1 To UBound(ar, 2)
                    brr(m, j) = ar(i, j)
                Next j
            End If
        End If
    Next i
    Sheets("各班调查表").Copy
    Set wb = ActiveWorkbook
    With wb.Worksheets(1)
        .Name = k & "班"
        .[a2] = "排查时间：           " & rq & "                           班主任（签名）: " & dc(k)
        .[a38] = "排查时间：           " & rq & "                           班主任（签名）: " & dc(k)
        .[a6].Resize(31, UBound(arr, 2)) = arr
        If m > 0 Then .[a42].Resize(m, UBound(brr, 2)) = brr
        For j = 3 To 14
            For i = 1 To n
                If arr(i, j) = "√" Then
                    .Cells(71, j) = .Cells(71, j) + 1
                End If
            Next i
        Next j
        For j = 3 To 14
            For i = 1 To m
                If brr(i, j) = "√" Then
                    .Cells(71, j) = .Cells(71, j) + 1
                End If
            Next i
        Next j
    End With
    wb.SaveAs Filename:=ThisWorkbook.Path & "\" & k & "班防溺水调查表.xlsx"
    wb.Close
Next k
Set d = Nothing
Set dc = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

防溺水排查表.rar (40.09 KB, 下载次数: 36)

2023-3-18 10:14 上传

点击文件名下载附件

jjmysjg

拆分总表到独立的工作簿

熊文来

3190496160 发表于 2023-3-18 10:14

感谢您的帮助，我试着修改以前的文件的代码，总是问题很多，然后就失去方向了。入门好难，主要是身边没有一个懂VBA的朋友可以指导。无法系统的学习。所以来求助大家。

熊文来

jjmysjg 发表于 2023-3-18 16:17
拆分总表到独立的工作簿

是的，再增加一个打印选项，打印每个文件的第1页还是第2页。

3190496160

熊文来 发表于 2023-3-18 22:37
感谢您的帮助，我试着修改以前的文件的代码，总是问题很多，然后就失去方向了。入门好难，主要是身边没有 ...

呵呵呵，你也是教师呀，学习应该是教师的强项吧，谁身边会有很多会代码的人，论坛就是最好的老师

熊文来

3190496160 发表于 2023-3-18 22:47
呵呵呵，你也是教师呀，学习应该是教师的强项吧，谁身边会有很多会代码的人，论坛就是最好的老师

目前我只会用函数，实现批量填充。但是生成一个独立的工作簿，进行打印，只能继续手动咯。

熊文来

3190496160 发表于 2023-3-18 10:13
Sub 分班()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant

老师，生成文件的排版和我源文件的有一些区别。


看看能不能把代码修改下，让排版按照我原来排版设置进行生成独立的工作簿。谢谢！