ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

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

[求助] 如何根据编排依据和模板生成单年级或全部标签20170623

[复制链接]

TA的精华主题

TA的得分主题

发表于 2017-6-23 18:23 | 显示全部楼层 |阅读模式
编排依据:分年级列出试场号,考室,人数。 如何根据编排依据和模板生成单年级或全部标签20170623.rar (7.78 KB, 下载次数: 6)

TA的精华主题

TA的得分主题

发表于 2017-6-23 19:12 | 显示全部楼层
  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.     For j = 1 To 9 Step 4
  8.       r = .Cells(.Rows.Count, j).End(xlUp).Row
  9.       arr = .Cells(1, j).Resize(r, 3)
  10.       For i = 2 To UBound(arr)
  11.         If Not d.exists(arr(i, 1)) Then
  12.           m = 1
  13.           ReDim brr(1 To 3, 1 To m)
  14.         Else
  15.           brr = d(arr(i, 1))
  16.           m = UBound(brr, 2) + 1
  17.           ReDim Preserve brr(1 To 3, 1 To m)
  18.         End If
  19.         brr(1, m) = arr(1, 3)
  20.         brr(2, m) = arr(i, 3)
  21.         brr(3, m) = arr(i, 2)
  22.         d(arr(i, 1)) = brr
  23.       Next
  24.     Next
  25.   End With
  26.   With Worksheets("标签成品全部样本")
  27.     .Range("a6:i" & .Rows.Count).Clear
  28.     n = 1
  29.     q = 1
  30.     .Range("a3:c5,g3:i5").ClearContents
  31.     For Each aa In d.keys
  32.       brr = d(aa)
  33.       ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
  34.       For i = 1 To UBound(brr)
  35.         For j = 1 To UBound(brr, 2)
  36.           crr(j, i) = brr(i, j)
  37.         Next
  38.       Next
  39.       .Cells(1, n) = "第" & aa & "考场"
  40.       With .Cells(1, n)
  41.         .Value = "第" & aa & "考场"
  42.         With .Characters(Start:=2, Length:=Len(aa)).Font
  43.           .Name = "Times New Roman"
  44.           .Size = 60
  45.         End With
  46.       End With
  47.       .Cells(3, n).Resize(UBound(crr), UBound(crr, 2)) = crr
  48.       n = n + 6
  49.       If n > 7 Then
  50.         q = q + 7
  51.         .Range("a1:i5").Copy .Cells(q, 1)
  52.         .Range("a3:c5,g3:i5").ClearContents
  53.         n = 1
  54.       End If
  55.     Next
  56.     If d.Count Mod 2 <> 0 Then
  57.       q = q + 7
  58.       .Range("a1:i5").Copy Cells(q, 1)
  59.     End If
  60.     .Range("a1:i7").Delete shift:=xlUp
  61.   End With
  62. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
yzyyyyyyy + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

发表于 2017-6-23 19:13 | 显示全部楼层
写了生成全部标签的代码,生成单个年级的标签代码很简单,楼主可借鉴修改完成。

如何根据编排依据和模板生成单年级或全部标签20170623.rar

19.75 KB, 下载次数: 12

评分

参与人数 1鲜花 +2 收起 理由
yzyyyyyyy + 2 优秀作品

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2017-6-23 19:59 来自手机 | 显示全部楼层
chxw68 发表于 2017-6-23 19:13
写了生成全部标签的代码,生成单个年级的标签代码很简单,楼主可借鉴修改完成。

感谢大师热心帮助,大师的代码匠心独运,回味无穷。单年级标签和全部年级标签,能否与年级,即7年级,8年级,9年级,全部,即单元格m1值关联,即选择值后运行程序,即在标签成品表中生成相应的标签。大师辛苦了。

TA的精华主题

TA的得分主题

发表于 2017-6-23 20:34 | 显示全部楼层
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

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

GMT+8, 2019-10-19 04:54 , Processed in 0.063503 second(s), 19 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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