VBA考试安排8778座次表

张祥荣 · 发表于 2014-12-24 16:22

本帖最后由张祥荣于 2014-12-24 16:26 编辑

feiren228 发表于 2014-12-24 00:54
测试》》》》

谢谢，但是我希望得到结果是8778的方式，而且排布方式是我的那种排布，如果人数减少的话，就是877*的方式，可以吗？

feiren228 · 发表于 2014-12-24 19:02

dyzx 发表于 2014-12-24 13:38
feiren228老师：一点生成考场座号键就出现对话框“下标越有-界”，同时这句显示黄色brr(s, 1 ...

详见附件！！

VBA考试安排_feiren228_V4.rar (241.28 KB, 下载次数: 19)

feiren228 · 发表于 2014-12-24 19:15

张祥荣发表于 2014-12-24 16:22
谢谢，但是我希望得到结果是8778的方式，而且排布方式是我的那种排布，如果人数减少的话，就是877*的方 ...

见附件》》》》》》》》》》》

VBA考试安排_feiren228_V5.rar (238.48 KB, 下载次数: 23)

feiren228 · 发表于 2014-12-24 19:52

应yzyyyyyyy的要求，座次7887排列！

VBA考试安排_feiren228_V6.rar (249.84 KB, 下载次数: 41)

张祥荣 · 发表于 2014-12-24 20:18

feiren228 发表于 2014-12-24 19:15
见附件》》》》》》》》》》》

				第		考场
考场地点：						起止号：
讲台
考号	姓名	座号	考号	姓名	座号	考号	姓名	座号	考号	姓名	座号
		1									30
		2			15			16			29
		3			14			17			28
		4			13			18			27
		5			12			19			26
		6			11			20			25
		7			10			21			24
		8			9			22			23

能不能这样的方式，还有一个问题就是班级考生信息那里不能安装样表的模版导出，请帮忙处理一下

feiren228 · 发表于 2014-12-24 21:19

张祥荣发表于 2014-12-24 20:18
能不能这样的方式，还有一个问题就是班级考生信息那里不能安装样表的模版导出，请帮忙处理一下

测试》》》》》

VBA考试安排_feiren228_V5-2.rar (247.35 KB, 下载次数: 14)

feiren228 · 发表于 2014-12-24 21:39

张祥荣发表于 2014-12-24 20:18
能不能这样的方式，还有一个问题就是班级考生信息那里不能安装样表的模版导出，请帮忙处理一下

解决个小bug

VBA考试安排_feiren228_V5-3.rar (239.91 KB, 下载次数: 53)

chxw68 · 发表于 2014-12-24 21:51

Sub 新座次表()
Dim r%, i%, c%, j%
Dim arr, kc, bt
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "试场*" Then
ws.Delete
End If
Next
With Worksheets("考场信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
kc = .Range("a2:c" & r)
End With
With Worksheets("考生信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:e" & r)
End With
k = 1
i = 1
Do While i <= UBound(arr)
ReDim brr(1 To 12, 1 To 12)
brr(1, 1) = "第" & kc(k, 1) & "考场"
brr(2, 1) = "考场地点：" & kc(k, 3)
brr(2, 9) = "起止号：" & arr(i, 1)
brr(3, 1) = "讲台"
For j = 1 To 10 Step 3
brr(4, j) = "考号"
brr(4, j + 1) = "姓名"
brr(4, j + 2) = "座号"
Next
Select Case kc(k, 2)
Case 30
brr(5, 4) = "#"
brr(5, 7) = "#"
Case 29
brr(5, 4) = "#"
brr(5, 7) = "#"
brr(5, 10) = "#"
Case 28
brr(5, 1) = "#"
brr(5, 4) = "#"
brr(5, 7) = "#"
brr(5, 10) = "#"
Case 27
brr(5, 1) = "#"
brr(5, 4) = "#"
brr(5, 7) = "#"
brr(5, 10) = "#"
brr(6, 10) = "#"
End Select
s = 1
m = 5
n = 1
Do While s <= kc(k, 2)
If brr(m, n) <> "#" Then
brr(m, n) = arr(i, 1)
brr(m, n + 1) = arr(i, 2)
brr(m, n + 2) = s
i = i + 1
s = s + 1
End If
If n Mod 2 = 1 Then
m = m + 1
If m = 13 Then
m = 12
n = n + 3
End If
Else
m = m - 1
If m = 4 Then
m = 5
n = n + 3
End If
End If
If n = 13 Or s > kc(k, 2) Or i > UBound(arr) Then
brr(2, 9) = brr(2, 9) & "-" & arr(i - 1, 1)
d(k) = brr
k = k + 1
Exit Do
End If
Loop
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = "试场" & k - 1
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
With .Cells(1, 1)
.Font.Name = "黑体"
.Font.Size = 20
.Resize(1, 12).Merge
End With
With .Cells(2, 1)
.Resize(1, 4).Merge
End With
With .Cells(2, 9)
.Resize(1, 4).Merge
End With
With .Cells(3, 1)
.Resize(1, 12).Merge
End With
.Range("a4:l12").Borders.LineStyle = xlContinuous
.Columns("a:l").AutoFit
.Rows("1:3").RowHeight = 40
.Rows("4:12").RowHeight = 30
With .UsedRange
.Replace What:="#", Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
If k > UBound(kc) Then
Exit Sub
End If
Loop
End Sub

复制代码

chxw68 · 发表于 2014-12-24 21:53

重新写了段生成座次安排表的程序，供楼主参考。

chxw68 · 发表于 2014-12-24 23:57

Sub 新座次表()
Dim r%, i%, c%, j%
Dim arr, kc, bt
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name Like "试场*" Then
ws.Delete
End If
Next
With Worksheets("考场信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
kc = .Range("a2:c" & r)
End With
With Worksheets("考生信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:e" & r)
End With
k = 1
s = 1
For i = 1 To Application.Min(UBound(arr), Application.Sum(Application.Index(kc, 0, 2)))
If s = 1 Then
ReDim brr(1 To 12, 1 To 12)
brr(1, 1) = "第" & kc(k, 1) & "考场"
brr(2, 1) = "考场地点：" & kc(k, 3)
brr(2, 8) = "起止号：" & arr(i, 1)
brr(3, 1) = "讲台"
For j = 1 To 10 Step 3
brr(4, j) = "考号"
brr(4, j + 1) = "姓名"
brr(4, j + 2) = "座号"
Next
m = 5
n = 1
End If
brr(m, n) = arr(i, 1)
brr(m, n + 1) = arr(i, 2)
brr(m, n + 2) = s
s = s + 1
If n Mod 2 = 1 Then
m = m + 1
If m = 13 Then
m = 12
n = n + 3
End If
Else
m = m - 1
If m = IIf(n = 4, 5, 4) Then
m = IIf(n = 4, 6, 5)
n = n + 3
End If
End If
If n = 13 Or s > kc(k, 2) Then
brr(2, 8) = brr(2, 8) & "-" & arr(i - 1, 1)
Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
With ws
.Name = "试场" & k
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
With .Cells(1, 1)
.Font.Name = "黑体"
.Font.Size = 22
.Resize(1, 12).Merge
End With
With .Cells(2, 1)
.Font.Bold = True
.Resize(1, 5).Merge
End With
With .Cells(2, 8)
.Font.Bold = True
.Resize(1, 5).Merge
End With
With .Cells(3, 1)
.Font.Name = "宋体"
.Font.Size = 18
.Font.Bold = True
.Resize(1, 12).Merge
End With
.Range("a4:l12").Borders.LineStyle = xlContinuous
.Columns("a:l").AutoFit
.Rows("1:3").RowHeight = 40
.Rows("4:12").RowHeight = 30
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
For j = 1 To 10 Step 3
.Cells(4, j).Resize(9, 3).BorderAround LineStyle:=xlContinuous, Weight:=xlThick
Next
End With
k = k + 1
s = 1
End If
Next
End Sub

复制代码

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

[求助] VBA考试安排8778座次表