按模板批量生成绩登记表

gwjkkkkk

模板修改了一下。。。

lb1280

gwjkkkkk 发表于 2024-1-11 21:09
704共57号，1表共56人，一班生成2个表？

刚看到了。就是这样做，非常多谢。如果有时人数多点人，我又可以在模板加多一行，又或少点人，我可以减少一行，麻烦可以告诉我代码里改哪几个参数可以改变这个结果？

lb1280

gwjkkkkk 发表于 2024-1-11 21:39
模板修改了一下。。。

非常感谢。就是这样。我再研究研究。

taotaole1999

好东西，果断收藏！

hjd528

我新建一个“班主任”工作表，增加班主任的信息。能否修改一下代码，在“打印”表中直接生成班主任的信息

hjd528

gwjkkkkk 发表于 2024-1-11 21:39
模板修改了一下。。。

老师你好，我新建一个“班主任”工作表，增加班主任的信息。能否修改一下代码，在“打印”表中直接生成班主任的信息。


按模板批量生成绩登记表（按班）.rar (61.11 KB, 下载次数: 4)

2024-1-13 11:01 上传

点击文件名下载附件

gwjkkkkk

hjd528 发表于 2024-1-13 11:01
老师你好，我新建一个“班主任”工作表，增加班主任的信息。能否修改一下代码，在“打印”表中直接生成班 ...

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&, n&, dic(1) As New Dictionary, vKey, Rng As Range, iPosRow&
   
    Application.ScreenUpdating = False
    ar = Sheets("班主任").[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        dic(0)(ar(i, 1)) = Array(ar(i, 2), ar(i, 3))
    Next i
    ar = Sheets("报名表").[A1].CurrentRegion.Value
   
    Set Rng = Sheets("模板").[A1:L34]
   
    For i = 3 To UBound(ar)
        dic(1)(ar(i, 4)) = dic(1)(ar(i, 4)) & " " & i
    Next i
    Cells.Delete
    For Each vKey In dic(1).keys
        cr = Split(dic(1)(vKey))
        ReDim br(1 To UBound(cr), 1 To 4)
        For i = 1 To UBound(br)
            For j = 1 To UBound(br, 2)
                br(i, j) = ar(cr(i), j + 1)
            Next j
        Next i
        
        br = cutArray(br, 30)
        n = n + 1
        iPosRow = (n - 1) * 34 + 1
        rngCopyToSame Rng, Cells(iPosRow, 1)
        If n > 1 Then ActiveSheet.HPageBreaks.Add Before:=Cells(iPosRow, 1)
        
        With Cells(iPosRow, 1)
            If dic(0).exists(vKey) Then
                .Cells(2, 3).Value = dic(0)(vKey)(0)
                .Cells(2, 9).Value = dic(0)(vKey)(1)
            End If
            For j = 1 To UBound(br)
                .Cells(4, (j - 1) * 6 + 2).Resize(UBound(br(j)), UBound(br(j), 2)) = br(j)
            Next j
        End With
    Next
   
    Erase dic
    Application.ScreenUpdating = True
    Beep
End Sub
Function cutArray(ByVal ar, iCutNum&) As Variant
    Dim br(), cr, i&, j&, iPosRow&, r&, k&
    For i = 1 To UBound(ar) Step iCutNum
        iPosRow = IIf((i + iCutNum - 1) > UBound(ar), UBound(ar) Mod iCutNum, iCutNum)
        ReDim cr(1 To iPosRow, 1 To UBound(ar, 2))
        For j = 1 To UBound(cr)
            For k = 1 To UBound(cr, 2)
                cr(j, k) = ar(i - 1 + j, k)
            Next k
        Next j
        r = r + 1
        ReDim Preserve br(1 To r)
        br(r) = cr
    Next i
    cutArray = br
End Function
Function rngCopyToSame(ByVal rngSel As Range, ByVal rngTarget As Range)
    Dim i&
    rngSel.Copy
    rngTarget.PasteSpecial xlPasteColumnWidths
    rngSel.Copy rngTarget
    With rngTarget.Resize(rngSel.Rows.Count, rngSel.Columns.Count)
        For i = 1 To .Rows.Count
            .Rows(i).RowHeight = rngSel.Rows(i).RowHeight
        Next i
    End With
End Function

gwjkkkkk

hjd528 发表于 2024-1-13 11:01
老师你好，我新建一个“班主任”工作表，增加班主任的信息。能否修改一下代码，在“打印”表中直接生成班 ...

请参考附件。。。

hjd528

gwjkkkkk 发表于 2024-1-13 18:53
请参考附件。。。

谢谢老师，让更多需要的人受益。