vba考场安排

chxw68 · 发表于 2019-12-18 08:39

Sub test2()
Dim r%, i%
Dim arr, brr, zrr()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
lk = [{7.13,14,14,3.63}]
With Worksheets("考场安排")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:f" & r)
End With
xm = ""
For i = 1 To UBound(arr)
If arr(i, 5) <> xm Then
m = m + 1
ReDim Preserve zrr(1 To 2, 1 To m)
zrr(1, m) = i
zrr(2, m) = i
xm = arr(i, 5)
Else
zrr(2, m) = i
End If
Next
With Worksheets("座位贴")
.Cells.Clear
For k = 1 To UBound(zrr, 2) Step 2
m0 = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(.Rows.Count, 6).End(xlUp).Row)
If m0 > 1 Then
m0 = m0 + 1
End If
hs = 0
For j = 1 To IIf(k + 1 <= UBound(zrr, 2), 2, 1)
If zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1 > hs Then
hs = zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1
End If
m = m0
n = j * 5 - 4
With .Cells(m, n)
.Value = arr(zrr(1, k + j - 1), 5) & "班教室"
.Resize(1, 4).Merge
With .Font
.Name = "等线"
.Size = 18
.Bold = True
End With
End With
For i = zrr(1, k + j - 1) To zrr(2, k + j - 1)
m = m + 1
.Cells(m, n) = arr(i, 2)
.Cells(m, n + 1) = arr(i, 3)
.Cells(m, n + 2) = arr(i, 1)
.Cells(m, n + 3) = arr(i, 4)
Next
With .Cells(m0 + 1, n).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 4)
.Borders.LineStyle = xlContinuous
With .Font
.Name = "等线"
.Bold = True
End With
End With
With .Cells(m0 + 1, n).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 1)
.NumberFormatLocal = "000"
With .Font
.Size = 18
End With
End With
With .Cells(m0 + 1, n + 1).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 2)
With .Font
.Size = 20
End With
End With
With .Cells(m0 + 1, n + 3).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 1)
.Orientation = xlVertical
.ShrinkToFit = True
With .Font
.Size = 8
End With
End With
Next
.Rows(m0).RowHeight = 23.25
.Rows(m0 + 1).Resize(hs).RowHeight = 52.5
Next
For j = 1 To UBound(lk)
.Columns(j).ColumnWidth = lk(j)
.Columns(j + 5).ColumnWidth = lk(j)
Next
.Columns(5).ColumnWidth = 3.38
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2019-12-18 08:40

修改好了。

shenjianrong163 · 发表于 2019-12-18 12:49

chxw68 发表于 2019-12-18 08:39

数组技能娴熟，代码简洁高效！谢谢！

chxw68 · 发表于 2019-12-18 14:21

shenjianrong163 发表于 2019-12-18 12:49
数组技能娴熟，代码简洁高效！谢谢！

呵呵，很会阅读代码呀。

shenjianrong163 · 发表于 2019-12-19 08:05

chxw68 发表于 2019-12-18 14:21
呵呵，很会阅读代码呀。

”考场安排”表还有点瑕疵：由于班级人数不均衡，导致后面的考场可能出现同一班级的学生前后排在一起（比如第34考场中五（1）班有两个学生前后在一起了），怎样在”考场安排”表中就解决这样的问题呢?

shenjianrong163 · 发表于 2019-12-19 22:44

chxw68 发表于 2019-12-18 08:40
修改好了。

”考场安排”表还有点瑕疵：由于班级人数不均衡，导致后面的考场可能出现同一班级的学生前后排在一起（比如第34考场中五（1）班有两个学生前后在一起了），怎样在”考场安排”表中就解决这样的问题呢?

chxw68 · 发表于 2019-12-20 08:11

shenjianrong163 发表于 2019-12-19 22:44
”考场安排”表还有点瑕疵：由于班级人数不均衡，导致后面的考场可能出现同一班级的学生前后排在一起（比 ...

不相邻问题是比较复杂的一个问题，你的教室布置就是2*29或者2*30？由于你这个情况班级比较多，这个问题相对比较简单，手工调整一下就行了。

shenjianrong163 · 发表于 2019-12-20 11:10

chxw68 发表于 2019-12-20 08:11
不相邻问题是比较复杂的一个问题，你的教室布置就是2*29或者2*30？由于你这个情况班级比较多，这个问题相 ...

好的，谢谢！

笨鸟飞不高 · 发表于 2021-8-20 09:11

考场布置.zip (111.35 KB, 下载次数: 11)

练习论坛老帖时遇到了问题（原来是重名造成的），感觉处理这种带姓名类的表，还是应该带上身份证号比较合理

onlycxb · 发表于 2021-8-21 15:21

shenjianrong163 发表于 2019-12-19 22:44
”考场安排”表还有点瑕疵：由于班级人数不均衡，导致后面的考场可能出现同一班级的学生前后排在一起（比 ...

不相邻问题会受很多因素限制。这是我的一个思路，请参考

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

[求助] vba考场安排

评分

最新热点 /1