制作简易的考试座位表

cai5926270

3190496160 发表于 2023-5-2 11:30
程序是需要严谨的逻辑的，什么情况下需要8列，什么情况下需要9列？？

11班需要9列，12班需要8列

3190496160

Sub 安排考场()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
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("成绩登记")
    .[a1].CurrentRegion.Sort .[c1], 2, , , , , , 1
    .[a1].CurrentRegion.Sort .[a1], 1, , , , , , 1
    ar = .[a1].CurrentRegion
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 1)) <> "" Then
        d(ar(i, 1)) = ""
    End If
Next i
For Each k In d.keys
    n = 0
    ReDim br(1 To UBound(ar), 1 To 1)
    For i = 2 To UBound(ar)
        If ar(i, 1) = k Then
            n = n + 1
            br(n, 1) = n & "." & ar(i, 2)
        End If
    Next i
    Sheets("模板").Copy after:=Sheets(Sheets.Count)
    With ActiveSheet
        .Name = k & "班"
        xh = 3
        If k = 11 Then
            bc = 9
        Else
            bc = 8
        End If
        For i = 1 To n Step bc
            xh = xh + 1
            lh = 0
            For s = i To i + bc - 1
                If s <= n Then
                    lh = lh + 1
                    .Cells(xh, lh) = br(s, 1)
                End If
            Next s
        Next i
         r = .Cells(Rows.Count, 1).End(xlUp).Row + 1
         .Cells(r, 7) = "打印日期："
         .Cells(r, 8) = Date
        .Range("a4").Resize(r - 4, bc).Borders.LineStyle = 1
    End With
Next k
Application.DisplayAlerts = True
MsgBox "ok!"
End Sub

3190496160

工作簿1.rar (23.65 KB, 下载次数: 23)

2023-5-2 14:06 上传

点击文件名下载附件

cai5926270

3190496160 发表于 2023-5-2 14:06

感谢大佬再次帮忙

cai5926270

cai5926270 发表于 2023-5-2 14:15
感谢大佬再次帮忙

您好！如果是按倒数第二列(不是固定列)排序代码怎么写?

cai5926270

3190496160 发表于 2023-5-2 14:06

您好！如果是按倒数第二列(不是固定列)排序代码怎么写?

3190496160

cai5926270

3190496160 发表于 2023-5-3 10:25

太好了，谢谢

cai5926270

zpy2 发表于 2023-5-2 09:36
create temp table aa as
select  (((row_number() over ( partition by 班级 order by 开学 desc))-1) / ...

谢谢高手帮助，有附件吗

cai5926270

再次感谢zpy2、3190496160两位高手。