ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 936|回复: 3

[求助] 如何根据各考场人数设置要求安排考场

[复制链接]

TA的精华主题

TA的得分主题

发表于 2020-1-16 09:29 | 显示全部楼层 |阅读模式
本帖最后由 zqlpop308 于 2020-1-16 11:12 编辑

一个考场人数一样的代码我已经写好了,但当人数不一样的时候不能实现,求根据考场人数设置要安排考场(起止考场号及人数是自己填写的,需要变动的),求各位vba大佬解决
设置要求.png

考场安排.zip

75.31 KB, 下载次数: 6

TA的精华主题

TA的得分主题

 楼主| 发表于 2020-1-17 09:00 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2020-1-17 12:22 | 显示全部楼层
详见附件。

考场安排.rar

66.52 KB, 下载次数: 22

TA的精华主题

TA的得分主题

发表于 2020-1-17 12:23 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  1. Sub test()
  2.   Dim r%, i%
  3.   Dim arr, brr
  4.   Dim d As Object
  5.   Application.ScreenUpdating = False
  6.   Application.DisplayAlerts = False
  7.   Set d = CreateObject("scripting.dictionary")
  8.   With Worksheets("sheet2")
  9.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  10.     arr = .Range("a2:b" & r)
  11.     ReDim frr(1 To Application.Sum(Application.Index(arr, 0, 2)))
  12.     m = 0
  13.     For i = 1 To UBound(arr)
  14.       For j = 1 To arr(i, 2)
  15.         m = m + 1
  16.         frr(m) = i & "考场" & j & "号座"
  17.       Next
  18.     Next
  19.   End With
  20.   With Worksheets("sheet1")
  21.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
  22.     arr = .Range("a1:m" & r)
  23.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2) - 5)
  24.     For i = 2 To UBound(arr)
  25.       For j = 4 To 6
  26.         If IsNumeric(arr(i, j)) Then
  27.           brr(i, 1) = brr(i, 1) + arr(i, j)
  28.         End If
  29.       Next
  30.       For j = 7 To UBound(arr, 2)
  31.         If IsNumeric(arr(i, j)) Then
  32.           brr(i, j - 5) = arr(i, j)
  33.         End If
  34.       Next
  35.     Next
  36.     brr(1, 1) = "语数外"
  37.     For j = 7 To UBound(arr, 2)
  38.       brr(1, j - 5) = arr(1, j)
  39.     Next
  40.     ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
  41.     For j = 1 To UBound(brr, 2)
  42.       crr(1, j) = brr(1, j)
  43.     Next
  44.     For j = 1 To UBound(brr, 2)
  45.       d.RemoveAll
  46.       For i = 2 To UBound(brr)
  47.         If Len(brr(i, j)) <> 0 And IsNumeric(brr(i, j)) Then
  48.           d(brr(i, j)) = d(brr(i, j)) + 1
  49.         End If
  50.       Next
  51.       nn = 1
  52.       kk = d.keys
  53.       For k = 0 To UBound(kk)
  54.         mm = Application.Large(kk, k + 1)
  55.         ss = d(mm)
  56.         d(mm) = nn
  57.         nn = nn + ss
  58.       Next
  59.       For i = 2 To UBound(brr)
  60.         If Len(brr(i, j)) <> 0 Then
  61.           crr(i, j) = d(brr(i, j))
  62.           d(brr(i, j)) = d(brr(i, j)) + 1
  63.         End If
  64.       Next
  65.     Next
  66.     ReDim drr(1 To UBound(crr), 1 To UBound(crr, 2) + 3)
  67.     For j = 1 To UBound(crr, 2)
  68.       drr(1, j) = crr(1, j) & "考场"
  69.     Next
  70.     For j = 1 To UBound(crr, 2)
  71.       For i = 2 To UBound(crr)
  72.         If Len(crr(i, j)) <> 0 Then
  73.           drr(i, j) = crr(1, j) & Space(2) & frr(crr(i, j))
  74.         End If
  75.       Next
  76.     Next
  77.     ls = UBound(drr, 2)
  78.     drr(1, ls - 2) = "语数外汇总"
  79.     drr(1, ls - 1) = "7选3汇总"
  80.     drr(1, ls) = "各科考场汇总"
  81.     For i = 2 To UBound(drr)
  82.       drr(i, ls - 2) = drr(i, 1)
  83.       For j = 2 To ls - 3
  84.         If Len(drr(i, j)) <> 0 Then
  85.           If IsEmpty(drr(i, ls - 1)) Then
  86.             drr(i, ls - 1) = drr(i, j)
  87.           Else
  88.             drr(i, ls - 1) = drr(i, ls - 1) & Space(2) & drr(i, j)
  89.           End If
  90.         End If
  91.       Next
  92.       If Len(drr(i, ls - 2)) <> 0 Then
  93.         drr(i, ls) = drr(i, ls - 2)
  94.       End If
  95.       If Len(drr(i, ls - 1)) <> 0 Then
  96.         drr(i, ls) = drr(i, ls) & Space(2) & drr(i, ls - 1)
  97.       End If
  98.     Next
  99.     .Range("o1").Resize(UBound(drr), UBound(drr, 2)) = drr
  100.   End With
  101.   Application.ScreenUpdating = True
  102.   MsgBox "考场安排完毕!"
  103. End Sub
复制代码

评分

2

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 13:08 , Processed in 0.047137 second(s), 14 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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