ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 EH云课堂直播课程免费学 打造核心竞争力的职场宝典
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 639|回复: 16

[求助] vba考场安排

[复制链接]

TA的精华主题

TA的得分主题

发表于 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

考场布置.rar

38.43 KB, 下载次数: 14

TA的精华主题

TA的得分主题

发表于 2019-12-17 09:39 | 显示全部楼层
供参考。

shenjianrong163_考场布置.rar

57.66 KB, 下载次数: 25

评分

参与人数 1鲜花 +1 收起 理由
shenjianrong163 + 1 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-17 16:19 | 显示全部楼层
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Set d = CreateObject("scripting.dictionary")
  6.   With Worksheets("基本信息")
  7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  8.     arr = .Range("a3:c" & r)
  9.   End With
  10.   For i = 1 To UBound(arr)
  11.     If Not d.exists(arr(i, 1)) Then
  12.       Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
  13.       d(arr(i, 1))(1) = 1
  14.     End If
  15.     If Not d(arr(i, 1)).exists(2) Then
  16.       m = 1
  17.       ReDim brr(1 To m)
  18.     Else
  19.       brr = d(arr(i, 1))(2)
  20.       m = UBound(brr) + 1
  21.       ReDim Preserve brr(1 To m)
  22.     End If
  23.     brr(m) = i
  24.     d(arr(i, 1))(2) = brr
  25.   Next
  26.   With Worksheets("考场设置")
  27.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  28.     brr = .Range("a3:d" & r)
  29.   End With
  30.   ReDim crr(1 To UBound(arr), 1 To 6)
  31.   kk = d.keys
  32.   k = 0
  33.   m = 1
  34.   For i = 1 To UBound(brr)
  35.     j = 1
  36.     Do While j <= brr(i, 3)
  37.       If kk(k) <> brr(i, 4) Then
  38.         j = j + 1
  39.         n = d(kk(k))(1)
  40.         drr = d(kk(k))(2)
  41.         If n <= UBound(drr) Then
  42.           crr(m, 1) = arr(drr(n), 1)
  43.           crr(m, 2) = arr(drr(n), 2)
  44.           crr(m, 3) = arr(drr(n), 3)
  45.           crr(m, 4) = brr(i, 1)
  46.           crr(m, 5) = brr(i, 2)
  47.           m = m + 1
  48.           n = n + 1
  49.           d(kk(k))(1) = n
  50.         End If
  51.       End If
  52.       k = k + 1
  53.       If k > UBound(kk) Then
  54.         k = 0
  55.       End If
  56.     Loop
  57.   Next
  58.   With Worksheets("考场安排")
  59.     .UsedRange.Offset(1, 0).Clear
  60.     .Range("a2").Resize(UBound(crr), UBound(crr, 2)) = crr
  61.   End With
  62. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
shenjianrong163 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-12-17 16:20 | 显示全部楼层
练练练手。

考场布置.rar

67.66 KB, 下载次数: 16

TA的精华主题

TA的得分主题

发表于 2019-12-17 18:39 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-17 19:40 | 显示全部楼层
本帖最后由 shenjianrong163 于 2019-12-17 20:08 编辑

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

TA的精华主题

TA的得分主题

发表于 2019-12-17 20:02 | 显示全部楼层
修改好了。

考场布置.rar

68.95 KB, 下载次数: 22

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-17 22:27 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-17 22:54 | 显示全部楼层

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

考场布置(增加座位贴).rar

82.6 KB, 下载次数: 3

TA的精华主题

TA的得分主题

发表于 2019-12-18 08:39 | 显示全部楼层
  1. Sub test2()
  2.   Dim r%, i%
  3.   Dim arr, brr, zrr()
  4.   Application.ScreenUpdating = False
  5.   Application.DisplayAlerts = False
  6.   lk = [{7.13,14,14,3.63}]
  7.   With Worksheets("考场安排")
  8.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  9.     arr = .Range("a2:f" & r)
  10.   End With
  11.   xm = ""
  12.   For i = 1 To UBound(arr)
  13.     If arr(i, 5) <> xm Then
  14.       m = m + 1
  15.       ReDim Preserve zrr(1 To 2, 1 To m)
  16.       zrr(1, m) = i
  17.       zrr(2, m) = i
  18.       xm = arr(i, 5)
  19.     Else
  20.       zrr(2, m) = i
  21.     End If
  22.   Next
  23.   With Worksheets("座位贴")
  24.     .Cells.Clear
  25.     For k = 1 To UBound(zrr, 2) Step 2
  26.       m0 = Application.Max(.Cells(.Rows.Count, 1).End(xlUp).Row, .Cells(.Rows.Count, 6).End(xlUp).Row)
  27.       If m0 > 1 Then
  28.         m0 = m0 + 1
  29.       End If
  30.       hs = 0
  31.       For j = 1 To IIf(k + 1 <= UBound(zrr, 2), 2, 1)
  32.         If zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1 > hs Then
  33.           hs = zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1
  34.         End If
  35.         m = m0
  36.         n = j * 5 - 4
  37.         With .Cells(m, n)
  38.           .Value = arr(zrr(1, k + j - 1), 5) & "班教室"
  39.           .Resize(1, 4).Merge
  40.           With .Font
  41.             .Name = "等线"
  42.             .Size = 18
  43.             .Bold = True
  44.           End With
  45.         End With
  46.         For i = zrr(1, k + j - 1) To zrr(2, k + j - 1)
  47.           m = m + 1
  48.           .Cells(m, n) = arr(i, 2)
  49.           .Cells(m, n + 1) = arr(i, 3)
  50.           .Cells(m, n + 2) = arr(i, 1)
  51.           .Cells(m, n + 3) = arr(i, 4)
  52.         Next
  53.         With .Cells(m0 + 1, n).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 4)
  54.           .Borders.LineStyle = xlContinuous
  55.           With .Font
  56.             .Name = "等线"
  57.             .Bold = True
  58.           End With
  59.         End With
  60.         With .Cells(m0 + 1, n).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 1)
  61.           .NumberFormatLocal = "000"
  62.           With .Font
  63.             .Size = 18
  64.           End With
  65.         End With
  66.         With .Cells(m0 + 1, n + 1).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 2)
  67.           With .Font
  68.             .Size = 20
  69.           End With
  70.         End With
  71.         With .Cells(m0 + 1, n + 3).Resize(zrr(2, k + j - 1) - zrr(1, k + j - 1) + 1, 1)
  72.           .Orientation = xlVertical
  73.           .ShrinkToFit = True
  74.           With .Font
  75.             .Size = 8
  76.           End With
  77.         End With
  78.       Next
  79.       .Rows(m0).RowHeight = 23.25
  80.       .Rows(m0 + 1).Resize(hs).RowHeight = 52.5
  81.     Next
  82.     For j = 1 To UBound(lk)
  83.       .Columns(j).ColumnWidth = lk(j)
  84.       .Columns(j + 5).ColumnWidth = lk(j)
  85.     Next
  86.     .Columns(5).ColumnWidth = 3.38
  87.     With .UsedRange
  88.       .HorizontalAlignment = xlCenter
  89.       .VerticalAlignment = xlCenter
  90.     End With
  91.   End With
  92. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关注官方微信,每天学会一个新技能

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2020-2-17 06:06 , Processed in 0.358034 second(s), 17 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:徐怀玉律师 李志群律师

快速回复 返回顶部 返回列表