怎样自动排考场座位号

BGX836260084

如一年级有6个班，312人，现需安排10个考场，要求各班在各考场人数基本平均，同班学生座位不能连在一起。

zpy2

create temp table aa as select rowid 行,姓名,年级,班级,((row_number() over (partition by 年级,班级)-1) % 10)+1 考场 from 排考场座位号明细表;create temp table bb as select *,row_number() over (partition by 考场,年级,班级) 考场内排序 from aa;select *,row_number() over (partition by 考场 order by 考场内排序) 座位 from bb order by 行

BGX836260084

怎么实现的，没看懂

大马峰

首先对考场进行排序，然后对一个考场进行奇偶数排序，即可

大马峰

1. =D3&IFERROR("、"&VLOOKUP($B3,$B4:G78,COLUMN(C1),0),"")

复制代码

BGX836260084

十分感谢！

3190496160

Sub 安排考场()
Application.ScreenUpdating = False
Dim r As Integer
Dim arr As Variant, brr As Variant
Dim d As Object, dc As Object, dd As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
With Sheets("设置")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:b" & rs)
End With

With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考生数据为空！": Exit Sub
    .[f1] = "随机数"
    zd = r - 1
    Randomize
    Do While mm < zd
    x = Int(Rnd * zd + 1)
        If Not dd.exists(x) Then
            mm = mm + 1
            .Cells(mm + 1, 6) = x
            dd(x) = ""
        End If
    Loop
    .Range("a1").Resize(r, 6).Sort .[f1], 1, , , , , , 1 '按随机数排序
    .Range("a1").Resize(r, 6).Sort .[c1], 1, , , , , , 1 '按随机数排序
    brr = .[a1].CurrentRegion
    For i = 2 To UBound(brr)
        If Trim(brr(i, 3)) <> "" Then
            d(Trim(brr(i, 3))) = d(Trim(brr(i, 3))) + 1
         End If
    Next i
   
    gs = d.Count
    For i = 2 To UBound(brr)
        If Not dc.exists(brr(i, 3)) Then
            nn = nn + 1
            brr(i, 4) = nn
            dc(brr(i, 3)) = ""
        Else
            brr(i, 4) = brr(i - 1, 4) + gs
        End If
   Next i
   For i = 2 To UBound(brr)
     For s = i + 1 To UBound(brr)
         If brr(i, 4) > brr(s, 4) Then
             For j = 1 To UBound(brr, 2)
                 Kk = brr(i, j)
                 brr(i, j) = brr(s, j)
                 brr(s, j) = Kk
             Next j
         End If
    Next s
  Next i

  n = 1
    For i = 2 To UBound(arr)
        If Trim(arr(i, 1)) <> "" And Trim(arr(i, 2)) <> "" Then
            sl = arr(i, 2)
            For s = 1 To sl
                n = n + 1
                brr(n, 4) = Format(arr(i, 1), "00")
                brr(n, 5) = Format(s, "00")
            Next s
        End If
    Next i
   
  .[a1].CurrentRegion = brr
  .Columns("f:f") = Empty
  .Select
End With
Application.ScreenUpdating = True
MsgBox "ok!" '
End Sub

3190496160

排考场座位号.rar (33.46 KB, 下载次数: 12)

2022-1-1 21:00 上传

点击文件名下载附件

3190496160

Sub 安排考场()
Application.ScreenUpdating = False
Dim r As Integer
Dim arr As Variant, brr As Variant
Dim d As Object, dc As Object, dd As Object
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
With Sheets("设置")
    rs = .Cells(Rows.Count, 1).End(xlUp).Row
    arr = .Range("a2:b" & rs)
End With

With Sheets("sheet1")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考生数据为空！": Exit Sub
    .[f1] = "随机数"
    zd = r - 1
    Randomize
    Do While mm < zd
    x = Int(Rnd * zd + 1)
        If Not dd.exists(x) Then
            mm = mm + 1
            .Cells(mm + 1, 6) = x
            dd(x) = ""
        End If
    Loop
    .Range("a1").Resize(r, 6).Sort .[f1], 1, , , , , , 1 '按随机数排序
    .Range("a1").Resize(r, 6).Sort .[c1], 1, , , , , , 1 '按随机数排序
    brr = .[a1].CurrentRegion
    For i = 2 To UBound(brr)
        If Trim(brr(i, 3)) <> "" Then
            d(Trim(brr(i, 3))) = d(Trim(brr(i, 3))) + 1
         End If
    Next i
   
    gs = d.Count
    For i = 2 To UBound(brr)
        If Not dc.exists(brr(i, 3)) Then
            nn = nn + 1
            brr(i, 4) = nn
            dc(brr(i, 3)) = ""
        Else
            brr(i, 4) = brr(i - 1, 4) + gs
        End If
   Next i
   For i = 2 To UBound(brr)
     For s = i + 1 To UBound(brr)
         If brr(i, 4) > brr(s, 4) Then
             For j = 1 To UBound(brr, 2)
                 Kk = brr(i, j)
                 brr(i, j) = brr(s, j)
                 brr(s, j) = Kk
             Next j
         End If
    Next s
  Next i

  n = 1
    For i = 2 To UBound(arr)
        If Trim(arr(i, 1)) <> "" And Trim(arr(i, 2)) <> "" Then
            sl = arr(i, 2)
            For s = 1 To sl
                n = n + 1
                brr(n, 4) = Format(arr(i, 1), "00")
                brr(n, 5) = Format(s, "00")
            Next s
        End If
    Next i
   
  .[a1].CurrentRegion = brr
  .Columns("f:f") = Empty
  .Select
End With
Application.ScreenUpdating = True
MsgBox "ok!" '
End Sub

scxlin

好设计，学习了。