求助：帮忙使用VBA安排考场，不胜感激！

LIUZHU

JS代码，这个问题还挺麻烦的

1. function 考场安排(){
   
2.         const arr=Sheets.Item("考场号和座位号安排").Range("a1").CurrentRegion.Value2;
   
3.         let obj={};
   
4.         let st=arr.slice(1).reduce((st,[,a,b],i)=>{
   
5.                 return obj[a]=i+1, st.add(b), st;
   
6.         },new Set());
   
7.         st.forEach(kd=>{
   
8.                 let ksarr=arr.filter(([,,b])=>b==kd);                //筛选点的考生
   
9.                 let ksct=Math.ceil(ksarr.length/30);
   
10.                 let dic={};
    
11.                 for (let k=1;k<=ksct;k++){
    
12.                         let temp=[[`第${k}考场考试座位安排表`],["前门","讲台"],...Array.from(Array(7),x=>Array(4)),["后门","",,,]];
    
13.                         let zw=0;
    
14.                         for (let j=3;j>=0;j--){
    
15.                                 for (let i=2;i<=9;i++){
    
16.                                         if (ksarr.length!=0 && temp[i][j]==null){
    
17.                                                 let n=parseInt(Math.random()*ksarr.length);                //随机抽取
    
18.                                                 temp[i][j]=ksarr.splice(n,1)[0][1];
    
19.                                                 let m=obj[temp[i][j]];
    
20.                                                 arr[m][3]=`${String(k).padStart(2,0)}${String(++zw).padStart(2,0)}`;                //准考证号
    
21.                                         }
    
22.                                 }
    
23.                         }
    
24.                         dic[k]=temp;
    
25.                 }
    
26.                 Sheets.Add(null,Sheets.Item(Sheets.Count)).Name=kd;
    
27.                 for (let key in dic){
    
28.                         let rng=Range("a"+ Rows.Count).End(xlUp);
    
29.                         rng=rng.Row==1?rng:rng.Offset(2,0);
    
30.                         let temp=dic[key];
    
31.                         rng.Resize(10,4).Value2=temp;
    
32.                         rng.Resize(10,4).HorizontalAlignment=xlHAlignCenter;
    
33.                         rng.Resize(10,4).Borders.LineStyle=1;
    
34.                         [[1,1,1,3],[0,0,1,4]].forEach(([a,b,c,d])=>rng.Offset(a,b).Resize(c,d).Merge());
    
35.                 }
    
36.         })
    
37.         Sheets.Item("考场号和座位号安排").Range("a1").CurrentRegion.Value2=arr;                //填入准考证号
    
38. }

复制代码

LIUZHU

附件，WPS打开测试

wang-way

sunya_0529 发表于 2024-6-19 23:45
WPS里的JSA练习一下——

看着代码量好吓人

sunya_0529

wang-way 发表于 2024-6-20 00:11
看着代码量好吓人

学习阶段，堆代码先出效果再说

3190496160

Sub 生成考号()
Application.ScreenUpdating = False
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("考场号和座位号安排")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "考场号和座位号安排为空！": End
    .Range("d2:d" & r) = Empty
    ar = .Range("a1:d" & r)
    For i = 2 To UBound(ar)
        If ar(i, 3) <> "" Then
            If Not d.exists(ar(i, 3)) Then Set d(ar(i, 3)) = CreateObject("scripting.dictionary")
            d(ar(i, 3))(i) = ""
        End If
    Next i
    .Range("a2:d" & r) = Empty
    For Each k In d.keys
        n = 0
        ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
        For Each kk In d(k).keys
            n = n + 1
            For j = 1 To 3
                br(n, j) = ar(kk, j)
            Next j
            br(n, 4) = WorksheetFunction.RandBetween(0, d(k).Count) '工作表随机函数
        Next kk
        For i = 1 To n
            For s = i + 1 To n
                If br(i, 4) > br(s, 4) Then
                    For j = 1 To 4
                        ff = br(i, j)
                        br(i, j) = br(s, j)
                        br(s, j) = ff
                    Next j
                End If
            Next s
        Next i
        m = 0
        For i = 1 To n Step 30
            m = m + 1
            t = 0
            For s = i To i + 29
                If s <= n Then
                    t = t + 1
                    br(s, 4) = Format(m, "00") & Format(t, "00")
                End If
            Next s
        Next i
        rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
        .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
    Next k
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

求助：随机考场和座位安排.rar (17.01 KB, 下载次数: 16)

2024-6-20 10:09 上传

点击文件名下载附件

3190496160

同一个考点内的考生随机打散安排考号，供参考

cai2532

3190496160 发表于 2024-6-20 10:09

非常感谢，有心了。

cai2532

LIUZHU 发表于 2024-6-19 23:51
附件，WPS打开测试

非常感谢大神！

cai2532

sunya_0529 发表于 2024-6-19 23:45
WPS里的JSA练习一下——

非常感谢大神！