如何在考场座位表里批量查找同班学生并自动填写每个学生的试室号？

rorbin36 · 发表于 2014-11-2 21:27

感谢chxw68大哥帮忙，附件是chxw68大哥帮忙做的，现在发现座位表可以很高效率排好，有个别试室的桌不够，可以手动调整。但现在发现有个难题，就是学生找自己的座位很难找，如果学生知道自已在哪个试室就容易找座位了。所以再请高手帮帮忙，如何把sheet2的座位表的学生的试室号，自动填到sheet1的试室号这列。谢谢！

九年级学业水平测试座位表.rar (14.38 KB, 下载次数: 39)

考试座位表.rar (16.19 KB, 下载次数: 67)

chxw68 · 发表于 2014-11-2 22:44

Sub test()
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim r%, i%, c%, j%
Dim arr, brr()
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:c" & r)
End With
For i = 1 To UBound(arr)
arr(i, 3) = Rnd()
Next
For i = 1 To UBound(arr) - 1
p = i
For j = i + 1 To UBound(arr)
If arr(p, 3) > arr(j, 3) Then
p = j
End If
Next
If p <> i Then
For k = 1 To 3
temp = arr(i, k)
arr(i, k) = arr(p, k)
arr(p, k) = temp
Next
End If
Next
ReDim brr(1 To 27, 1 To 9)
r = 23
c = 1
m = 1
n = 1
For i = 1 To UBound(arr)
brr(r, c) = "座位号:" & Format(n, "00")
brr(r - 1, c) = arr(i, 1)
brr(r - 2, c) = arr(i, 2)
xm = arr(i, 1) & "+" & arr(i, 2)
d1(xm) = m & "试室" & Format(n, "00号")
n = n + 1
If c = 1 Or c = 5 Or c = 9 Then
r = r - 4
Else
r = r + 4
End If
If r = -1 Then
c = c + 2
r = 3
ElseIf r = 27 Then
c = c + 2
r = 23
End If
If c > 9 Or i = UBound(arr) Then
brr(26, 5) = "讲台"
brr(26, 9) = "第" & m & "试室"
brr(27, 9) = "共" & n - 1 & "人"
d(m) = brr
ReDim brr(1 To 27, 1 To 9)
r = 23
c = 1
n = 1
m = m + 1
End If
Next
m = 1
With Worksheets("sheet2")
.Cells.Clear
For Each aa In d.Keys
brr = d(aa)
.Cells(m, 1).Resize(UBound(brr), UBound(brr, 2)) = brr
For i = 1 To 21 Step 4
For j = 1 To 9 Step 2
With .Cells(i + m - 1, j).Resize(3, 1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
End With
Next
Next
With .Cells(m + 25, 5)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
End With
With .Cells(m + 25, 9).Resize(2, 1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
m = m + 31
Next
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:c" & r)
For i = 1 To UBound(arr)
xm = arr(i, 1) & "+" & arr(i, 2)
If d1.Exists(xm) Then
arr(i, 3) = d1(xm)
End If
Next
.Range("c1") = "试室号"
.Range("c2").Resize(UBound(arr), 1) = Application.Index(arr, 0, 3)
End With
End Sub

复制代码

chxw68 · 发表于 2014-11-2 22:47

刚看到楼主的贴子，睡觉前匆匆忙忙改了一下代码，手动修改的功能也没实现，先请楼主看一看，明天再仔细修改。

dfsf12 · 发表于 2014-11-2 23:07

代码写的好，学习了

jpj123 · 发表于 2014-11-2 23:14

我也写改了下，看看是楼主要的效果不？

chxw68 · 发表于 2014-11-3 08:59

Sub 生成试室号()
Dim d As New Dictionary
Dim r%, i%, c%, j%
Dim arr, brr
With Worksheets("sheet2")
r = .Cells(.Rows.Count, 9).End(xlUp).Row
For k = 1 To r Step 28
arr = .Cells(k, 1).Resize(27, 9)
For i = 1 To UBound(arr) - 4 Step 4
For j = 1 To 9 Step 2
If Len(arr(i, j)) <> 0 Then
xm = arr(i + 1, j) & "+" & arr(i, j)
d(xm) = arr(26, 9) & Split(arr(i + 2, j), ":")(1) & "号"
End If
Next
Next
Next
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:c" & r)
For i = 1 To UBound(arr)
xm = arr(i, 1) & "+" & arr(i, 2)
If d.Exists(xm) Then
arr(i, 3) = d(xm)
End If
Next
.Range("c1") = "试室号"
.Range("c2").Resize(UBound(arr), 1) = Application.Index(arr, 0, 3)
End With
End Sub

复制代码

chxw68 · 发表于 2014-11-3 09:02

重新写了生成试室号的代码。当点击[排列座位]按钮时在生成座位表的同时会将试室号复制到花名册，手动调整后按[生成试室号]按钮会复制新的试室号到花名册。

rorbin36 · 发表于 2014-11-3 09:11

本帖最后由 rorbin36 于 2014-11-3 09:18 编辑

chxw68 发表于 2014-11-3 09:02
重新写了生成试室号的代码。当点击[排列座位]按钮时在生成座位表的同时会将试室号复制到花名册，手动调整后 ...

chxw68大哥，不行哦，手动调整后，按生成试室号，所有的座位又重新排过一次，全变了！

rorbin36 · 发表于 2014-11-3 09:13

可以了，原来是生成试室号那个按钮的指定宏弄错了。

rorbin36 · 发表于 2014-11-3 09:26

大哥还有第二个附件呀！劳烦大哥帮忙弄下第二个附件的表格，谢谢！

		自动登录	找回密码
密码			免费注册

[求助] 如何在考场座位表里批量查找同班学生并自动填写每个学生的试室号？