制作一个VBA宏代码，将“班级表”中的学生按班级分到“各班座次表”的相应班级中

gwjkkkkk

lc16whj 发表于 2023-8-8 15:41
大神，能不能再帮忙制作一个VBA宏代码，将“班级表”中的学生按考场分到“考场座位表”的相应考场中去， ...

请参考。。。

lc16whj

liulang0808 发表于 2023-8-8 19:38
模拟结果供参考

大神，左侧座位号从1到30，右侧座位号从31号开始，您的VBA宏，会使每个考场都缺少座位号31，能不能再帮忙修正一下VBA代码？谢谢！

lc16whj

gwjkkkkk 发表于 2023-8-8 20:26
请参考。。。

大神，不是按班级分学生，而是要按考场分学生，学生按考生的座位号顺序排列！结果请参阅考场座位表效果图！

lc16whj

liulang0808 发表于 2023-8-8 08:23
如果都是按照第三列排序的，可以不使用字典，直接赋值数据也可以的

大神，这个宏代码是按1到15班的顺序排列的，没有问题！

lushang2018

lc16whj

lushang2018 发表于 2023-8-8 22:44

谢谢大神，这样打印好麻烦，我要把所有的学生放在同一工作表中，方便排版和打印！

lc16whj

LIUZHU 发表于 2023-8-8 09:08
用WPS软件测试

我沒有安装WPS！谢谢大神

lc16whj

liulang0808 发表于 2023-8-8 19:38
Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    brr = Sheets("班级").[c1:h1 ...

大神，问题找到了：

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    brr = Sheets("班级").[c1:h1]
    arr = Sheets("班级").UsedRange
    For j = 2 To UBound(arr)
        If Len(arr(j, 2)) > 0 Then
            If Not d.exists(arr(j, 2)) Then
                Set d(arr(j, 2)) = CreateObject("scripting.dictionary")
            End If
            d(arr(j, 2))(j) = ""
        End If
    Next j
    Application.ScreenUpdating = False
    r = 1
    With Sheets("考场座位表")
        .UsedRange.ClearContents
        For Each k In d.keys
            .Cells(r, 2).Resize(1, 6) = brr
            .Cells(r, 9).Resize(1, 6) = brr
            c = -1
            rx = 1
            For Each kk In d(k).keys
                If rx = 31 Then
                    c = 6
                    rx = 1
                End If
                For i = 3 To 8
                    .Cells(rx + r, c + i) = arr(kk, i)
                Next i
                rx = rx + 1
            Next kk
            r = r + 31
        Next k
    End With
    Application.ScreenUpdating = True
End Sub
只要把 If rx = 32 Then这句中的32改成31即可！