VBA批量生成准考证

sickman55

修改了某个前辈的准考证，去除了照片（省墨！），平时用不需要这个功能。一个可以批量生成准考证的vba，不包含排考场和座位，只是单纯生成准考证，缺点是不能按班级生成，希望高手可以把它变成按班级生成的。

3190496160

Sub zhunkaozheng()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Dim br()
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 2 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
With Sheets("考生资料")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考生资料为空！": End
    ar = .Range("A1:H" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        d(Trim(ar(i, 4))) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    For i = 2 To UBound(ar)
        If Trim(ar(i, 4)) = k Then
            n = n + 1
            For j = 1 To UBound(ar, 2)
                br(n, j) = ar(i, j)
            Next j
        End If
    Next i
    Sheets("准考证").Copy after:=Sheets(Sheets.Count)
    With Sheets(Sheets.Count)
        .Name = "准考证-" & k
        If n / 2 = Int(n / 2) Then
            sl = n / 2
        Else
            sl = Int(n / 2) + 1
        End If
        m = 17
        For i = 2 To sl
            .Rows("1:16").Copy .Cells(m, 1)
            m = m + 16
        Next i
        m = 4
        For i = 1 To n Step 2
            .Cells(m, 2) = br(i, 2)
            .Cells(m + 1, 2) = br(i, 3)
            .Cells(m + 2, 2) = br(i, 4)
            .Cells(m + 3, 2) = br(i, 5)
            .Cells(m + 4, 2) = br(i, 6)
            .Cells(m + 4, 5) = br(i, 7)
            
            If i + 1 <= n Then
                .Cells(m, 9) = br(i + 1, 2)
                .Cells(m + 1, 9) = br(i + 1, 3)
                .Cells(m + 2, 9) = br(i + 1, 4)
                .Cells(m + 3, 9) = br(i + 1, 5)
                .Cells(m + 4, 9) = br(i + 1, 6)
                .Cells(m + 4, 12) = br(i + 1, 7)
            End If
            m = m + 16
        Next i
    End With
Next k
Sheets("考生资料").Select
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

参考
准考证.rar (252.64 KB, 下载次数: 132)

2023-4-26 17:35 上传

点击文件名下载附件

清风竹-

参与一下。

xingruyubb

新高考，不同科目的考试学生所在的考场可能会有区别，不知道这个准考证上是否可以修改成每科所在的考场以及座号？

sickman55

3190496160 发表于 2023-4-26 17:34
Sub zhunkaozheng()
Application.ScreenUpdating = False
Dim ar As Variant

非常感谢！！！太厉害了。

sickman55

3190496160 发表于 2023-4-26 17:35
参考

谢谢收到！

sickman55

清风竹- 发表于 2023-4-26 18:46
参与一下。

就我个人来说，我喜欢这个版，能不能根据班级人数判断最后是剩余准考证人数是3、2、1分别只产生相应个数的准考证？

sickman55

清风竹- 发表于 2023-4-26 18:46
参与一下。

这个是一直用的VBA加公式版，可以按照要求，根据班级人数判断，生成的准考证数量，缺点是要实时打印。设想改成直接生成准考证到一个表里然后再打印。工程密码是 dorothy

sickman55

3190496160 发表于 2023-4-26 17:35
参考

清大神看看我这vba函数版的新高考准考证，看看能不能给5楼的用。不太会编程。工程密码是桃乐西 dorothy