vba考场安排

shenjianrong163 · 发表于 2019-12-17 01:18

现有“基本信息表”“考场布置表”和“考场安排表”，“基本信息表”已经按照班级排列，准备从“基本信息表”中每班取1个学生循环组成考场，“考场布置表”中有各考场所对应的学生数，并且部分考场规定不能出现的班级学生（比如第一考场29人并且不安排（1）班的人，则为五（2）五（3）五（4）五（5）五（6）五（7）五（8）五（9）五（10）五（11）五（12）五（13）五（14）五（15）五（16）五（17）五（18）五（2）五（3）五（4）五（5）五（6）五（7）五（8）五（9）五（10）五（11）五（12）五（13））。自己写了段代码，运行后发现（1）班有两个学生没有安排到。请高手帮忙解决下，或者看看怎样编写代码更好！
Sub 主程序()
Dim Dic, Arr
Dim i As Integer, r As Integer, j, k
Dim Str As String
r = Sheets("基本信息").Cells(Rows.Count, 1).End(xlUp).Row
If r = 1 Then Exit Sub '如果第一列没有数据那么退出程序
Set Dic = CreateObject("scripting.dictionary") '创建字典对象
For i = 3 To r '将第一列数据添加到字典的key值中
Dic(CStr(Sheets("基本信息").Cells(i, 1))) = ""
Next
Arr = Dic.keys '返回字典key的数组
Set Dic = Nothing '销毁对象
Call 班级学生间隔排列(Arr)
End Sub

Sub 班级学生间隔排列(Arr)

Dim i&, j&, k&, m&, n&, flag&, Infor_num&, Exam_num&
Infor_num = Sheets("基本信息").Cells(Rows.Count, 1).End(xlUp).Row    '基本信息表的总行数
Exam_num = Sheets("考场设置").Cells(Rows.Count, 1).End(xlUp).Row    '考场设置表的总行数
flag = 0
  For i = 3 To Exam_num
   For j = 1 To Sheets("考场设置").Cells(i, 3)
      For k = flag To UBound(Arr)
         For m = 3 To Infor_num
            n = 0
            If Arr(k) = Sheets("考场设置").Cells(i, 4) Then
               flag = k + 1
               Exit For
            End If

            If Sheets("基本信息").Range("A" & m) = Arr(k) And Sheets("考场设置").Cells(i, 4) <> Arr(k) And Sheets("基本信息").Range("A" & m).Font.Color <> 255 Then
               Sheets("基本信息").Rows(m).Copy Sheets("考场安排").Range("A" & Infor_num).End(3).Offset(1)
               Sheets("基本信息").Range("A" & m).Font.Color = 255
               n = 1
            End If
            If n = 1 Then
               If k = UBound(Arr) Then
                  flag = 0
               Else
                  flag = k + 1
               End If
                  Exit For
            End If

         Next
         If n = 1 Then
            Exit For
         Else
            flag = 0
         End If
      Next
   Next
Next

For i = 3 To Infor_num
   Sheets("基本信息").Cells(i, 1).Font.ColorIndex = xlAutomatic  '设置为黑色
Next
End Sub

山菊花 · 发表于 2019-12-17 09:39

供参考。

chxw68 · 发表于 2019-12-17 16:19

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("基本信息")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a3:c" & r)
End With
For i = 1 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
d(arr(i, 1))(1) = 1
End If
If Not d(arr(i, 1)).exists(2) Then
m = 1
ReDim brr(1 To m)
Else
brr = d(arr(i, 1))(2)
m = UBound(brr) + 1
ReDim Preserve brr(1 To m)
End If
brr(m) = i
d(arr(i, 1))(2) = brr
Next
With Worksheets("考场设置")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
brr = .Range("a3:d" & r)
End With
ReDim crr(1 To UBound(arr), 1 To 6)
kk = d.keys
k = 0
m = 1
For i = 1 To UBound(brr)
j = 1
Do While j <= brr(i, 3)
If kk(k) <> brr(i, 4) Then
j = j + 1
n = d(kk(k))(1)
drr = d(kk(k))(2)
If n <= UBound(drr) Then
crr(m, 1) = arr(drr(n), 1)
crr(m, 2) = arr(drr(n), 2)
crr(m, 3) = arr(drr(n), 3)
crr(m, 4) = brr(i, 1)
crr(m, 5) = brr(i, 2)
m = m + 1
n = n + 1
d(kk(k))(1) = n
End If
End If
k = k + 1
If k > UBound(kk) Then
k = 0
End If
Loop
Next
With Worksheets("考场安排")
.UsedRange.Offset(1, 0).Clear
.Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
End With
End Sub

复制代码

chxw68 · 发表于 2019-12-17 16:20

练练练手。

liuxi001 · 发表于 2019-12-17 18:39

http://club.excelhome.net/thread-1455269-1-1.html
2楼座次采用先排序再生成考号等信息，看对楼主有没有帮助

shenjianrong163 · 发表于 2019-12-17 19:40

本帖最后由 shenjianrong163 于 2019-12-17 20:08 编辑

chxw68 发表于 2019-12-17 16:19

您编写的这段代码效率很高！现在还有一个小问题，学生总数是991，您的总数少了11人，33考场少了1人,34考场少了10人，请再看看问题出在哪儿！同时请帮忙看看“考场安排表”中的“考号”重新从001开始编写。谢谢！

chxw68 · 发表于 2019-12-17 20:02

修改好了。

shenjianrong163 · 发表于 2019-12-17 22:27

chxw68 发表于 2019-12-17 20:02
修改好了。

代码简洁，效率高，谢谢！

shenjianrong163 · 发表于 2019-12-17 22:54

chxw68 发表于 2019-12-17 20:02
修改好了。

现增加一个“座位贴”表，要求每个考场按“座位贴”中的格式分两栏显示并且在一张A4纸上排版好，怎样编写代码更高率呢?谢谢！

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

复制代码

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

[求助] vba考场安排

评分

评分

最新热点 /1