同一考场内前后座位号不同班

sunshuangzhong

liulang0808

Sub 按钮2_Click()
    Dim brr(1 To 2)
    Set d = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For j = 2 To UBound(arr) - 1
        If Not d.exists(arr(j, 3)) Then
            d(arr(j, 3)) = j
        Else
            If arr(j, 3) = arr(j + 1, 3) And arr(j, 2) = arr(j + 1, 2) Then
                For i = j - 2 To d(arr(j, 3)) + 1 Step -1
                    If arr(i - 1, 2) <> arr(j, 2) And arr(i, 2) <> arr(j, 2) Then
                        brr(1) = arr(j, 1)
                        brr(2) = arr(j, 2)
                        For x = j To i + 1 Step -1
                            arr(x, 1) = arr(x - 1, 1)
                            arr(x, 2) = arr(x - 1, 2)
                        Next x
                        arr(i, 1) = brr(1)
                        arr(i, 2) = brr(2)
                        Exit For
                    End If
                Next i
            End If
        End If
    Next j
    [a1].CurrentRegion = arr
End Sub

liulang0808

附件内容供参考。。。。

sunshuangzhong

liulang0808的棒！同一考场内一次性调整到位！
我的代码要多次调整，不好！再次感谢liulang0808！
Sub test()
Dim arr
arr = [a1].CurrentRegion
Dim i As Integer, r As Long, s As String
r = Range("A1").End(xlDown).Row
For i = 2 To r - 2
    If arr(i, 2) = arr(i + 1, 2) And arr(i, 3) = arr(i + 1, 3) Then
        s = arr(i + 1, 4)
        arr(i + 1, 4) = arr(i + 2, 4)
        arr(i + 2, 4) = s
    End If
Next i
Range("S1:V" & r) = arr
End Sub

3190496160

Sub 班级不相连安排考场()
Dim r As Integer
Dim i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("设置")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox "请先设置考场号和考场人数！": Exit Sub
    rr = .Range("a1:b" & rs)
End With
With Sheet1
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考生数据为空！": Exit Sub
    .Range("c2:d" & r) = Empty
    .Range("a1").Resize(r, 2).Sort .[b1], 1, , , , , , 1 '按班级排序
    arr = .Range("a2:d" & r)
    n = 0
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 2)) Then
            n = n + 1
            d(arr(i, 2)) = n
        End If
    Next
    For i = 1 To UBound(arr)
        arr(i, 3) = d(arr(i, 2))
        d(arr(i, 2)) = d(arr(i, 2)) + d.Count
    Next
    For i = 1 To UBound(arr)
        For s = i + 1 To UBound(arr)
            If arr(i, 3) > arr(s, 3) Then
                For j = 1 To UBound(arr, 2)
                    K = arr(i, j)
                    arr(i, j) = arr(s, j)
                     arr(s, j) = K
                Next j
            End If
        Next s
    Next i
        For s = 2 To UBound(rr)
            If Trim(rr(s, 1)) <> "" Then
                For y = 1 To rr(s, 2)
                    nn = nn + 1
                    arr(nn, 3) = rr(s, 1)
                    arr(nn, 4) = Format(y, "00")
                Next y
            End If
        Next s
    .Columns("C:D").NumberFormatLocal = "@"
    .Range("a2:d" & r) = arr
End With
MsgBox "ok!"
End Sub

3190496160

目前代码可以实现：
1、按考生班级不相连安排考场
2.可以自由设定各个考场的考生数

sunshuangzhong

6楼代码好像有问题：最后一个考场都是同一个班的人，且按下按钮永远都是一个排法。其实如果是全年级整个打乱排考场，思路可以是：先使用辅助列，生成随机号；按班级和随机号排序；根据每个考场人数,重复赋起始考场号到终止考场号。
2楼代码也有点问题：每个考场前几个人如果同班，无法更换！
再次感谢两位前辈的探讨！
附6楼的代码，方便查看！
Sub 班级不相连安排考场()
Dim r As Integer
Dim i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("设置")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    If rs < 2 Then MsgBox "请先设置考场号和考场人数！": Exit Sub
    rr = .Range("a1:b" & rs)
End With
With Sheet1
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考生数据为空！": Exit Sub
    .Range("c2:d" & r) = Empty
    .Range("a1").Resize(r, 2).Sort .[b1], 1, , , , , , 1 '按班级排序
    arr = .Range("a2:d" & r)
    n = 0
    For i = 1 To UBound(arr)
        If Not d.exists(arr(i, 2)) Then
            n = n + 1
            d(arr(i, 2)) = n
        End If
    Next
    For i = 1 To UBound(arr)
        arr(i, 3) = d(arr(i, 2))
        d(arr(i, 2)) = d(arr(i, 2)) + d.Count
    Next
    For i = 1 To UBound(arr)
        For s = i + 1 To UBound(arr)
            If arr(i, 3) > arr(s, 3) Then
                For j = 1 To UBound(arr, 2)
                    K = arr(i, j)
                    arr(i, j) = arr(s, j)
                     arr(s, j) = K
                Next j
            End If
        Next s
    Next i
        For s = 2 To UBound(rr)
            If Trim(rr(s, 1)) <> "" Then
                For y = 1 To rr(s, 2)
                    nn = nn + 1
                    arr(nn, 3) = rr(s, 1)
                    arr(nn, 4) = Format(y, "00")
                Next y
            End If
        Next s
    .Columns("C:D").NumberFormatLocal = "@"
    .Range("a2:d" & r) = arr
End With
MsgBox "ok!"
'ActiveWorkbook.FollowHyperlink Address:="http://wpa.qq.com/msgrd?v=3&uin=705664849&site=qq&menu=yes", NewWindow:=True
End Sub

3190496160

sunshuangzhong 发表于 2020-7-21 21:57
6楼代码好像有问题：最后一个考场都是同一个班的人，且按下按钮永远都是一个排法。其实如果是全年级整个打 ...

呵呵呵，最后一个考场都是同一个班级的问题，你看看下面这张截图就应该会明白了，实际的班级人数，会这样吗？？？其他的不想说什么

chxw68

楼上朋友是不是统计错了？