ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

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

[求助] vba考场安排

[复制链接]

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
复制代码

TA的精华主题

TA的得分主题

发表于 2019-12-18 08:40 | 显示全部楼层
修改好了。

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

103.17 KB, 下载次数: 32

评分

参与人数 2鲜花 +4 收起 理由
shenjianrong163 + 2 优秀作品
vvw123 + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-18 12:49 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-12-18 14:21 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-19 08:05 | 显示全部楼层
chxw68 发表于 2019-12-18 14:21
呵呵,很会阅读代码呀。

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

TA的精华主题

TA的得分主题

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

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

TA的精华主题

TA的得分主题

发表于 2019-12-20 08:11 | 显示全部楼层
shenjianrong163 发表于 2019-12-19 22:44
”考场安排”表还有点瑕疵:由于班级人数不均衡,导致后面的考场可能出现同一班级的学生前后排在一起(比 ...

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-12-20 11:10 | 显示全部楼层
chxw68 发表于 2019-12-20 08:11
不相邻问题是比较复杂的一个问题,你的教室布置就是2*29或者2*30?由于你这个情况班级比较多,这个问题相 ...

好的,谢谢!
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2020-3-29 08:58 , Processed in 0.070240 second(s), 17 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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