注册 登录  
 加关注
   显示下一条  |  关闭
温馨提示!由于新浪微博认证机制调整,您的新浪微博帐号绑定已过期,请重新绑定!立即重新绑定新浪微博》  |  关闭

奕克

爱家人爱工作爱生活

 
 
 

日志

 
 

自动生成考场座位贴的VBA程序  

2013-12-29 19:59:45|  分类: office |  标签: |举报 |字号 订阅

  下载LOFTER 我的照片书  |
       下周要在机房考试,4个班在3个机房混考,要隔着位置座,所以座位我自己分了分,教办的说系统打出来的座位贴可能是整门课混一起的。。。于是乎我想起来以前教务管理系统不能打印座位贴时我写的一个程序,给学生上office课做例子的,那时还不知道有word邮件合并,后来看到了word邮件合并,感觉我这程序就可有可无了,要说好,也就这程序能一排打印多个记录,没试过邮件合并行不行。。。这次把它改了改,更通用点,我还是喜欢用这个打座位贴,用自己写的程序感觉是不一样的。。。相关excel在(http://dl.vmall.com/c02co3nc4t里,下载后最好禁用宏打开,看一下代码是否跟我的日志源码一致,不知道网盘数据会不会被黑客攻击:
          excel的第一个表是数据表:放需要生成座位贴的数据,如图:
 自动生成考场座位贴的VBA程序 - wucccsk - 生活如此多姿多彩
  第二页是配置页,用来决定一页打几行座位贴(这个需要自己打印机预览估计一下A4能放几行模板),然后A4一横排印几条记录。还有个模板占用了几行几列,表示第3个模板页模板占用了几行几列的excel单元格,因为模板是需要合并单元格生成的。
自动生成考场座位贴的VBA程序 - wucccsk - 生活如此多姿多彩
 上面写了模板占据了10行5列,所以相应的第三页模板如下,一般来说模板行列数不需要改。
自动生成考场座位贴的VBA程序 - wucccsk - 生活如此多姿多彩
   程序思路很简单,在数据表中根据列名,比如班级列,填入相应模板的<班级>处,把数据表每个字段这么处理完,就生成了一张座位贴。
          打开工作簿,启用宏,第一个表贴入你的数据,第二个表写入打印纸的记录格式安排,第三个表的模板设置一下想要的字体,点击工具栏的“生成座位贴”,结果就在第4个表里,非常简单。。。。
         源码如下:
        
Sub sc()
   Application.ScreenUpdating = False
   break = Worksheets(2).Cells(1, 2).Value
   pbreak = Worksheets(2).Cells(4, 2).Value * Worksheets(2).Cells(1, 2).Value
   hang = Worksheets(2).Cells(2, 2).Value
   lie = Worksheets(2).Cells(3, 2).Value
   liechar = Chr(Asc("A") + lie - 1)
   m = 1: n = 0: c = 0
   For i = 2 To Worksheets(1).UsedRange.Rows.Count
     Application.StatusBar = "正在处理第" & i & "条记录"
    Worksheets(3).Activate
    Worksheets(3).Range("A1:" & liechar & hang).Select
    Selection.Copy
    Worksheets(4).Activate
    Worksheets(4).Range("A1:" & liechar & hang).Offset(m, n).Select
    Selection.PasteSpecial
    For j = 1 To Worksheets(1).UsedRange.Columns.Count
        ActiveCell.Replace What:="<" & Worksheets(1).Cells(1, j).Value & ">", Replacement:=Worksheets(1).Cells(i, j).Value, LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Next
    n = n + lie:    c = c + 1
    If c Mod break = 0 Then
        c = 0: n = 0: m = m + hang
    End If
    If (i - 1) Mod pbreak = 0 Then
        Worksheets(4).HPageBreaks.Add Worksheets(4).Range("A" & (m + 1))
    End If
  Next
   Application.ScreenUpdating = True
End Sub


 
  评论这张
 
阅读(185)| 评论(0)
推荐 转载

历史上的今天

在LOFTER的更多文章

评论

<#--最新日志,群博日志--> <#--推荐日志--> <#--引用记录--> <#--博主推荐--> <#--随机阅读--> <#--首页推荐--> <#--历史上的今天--> <#--被推荐日志--> <#--上一篇,下一篇--> <#-- 热度 --> <#-- 网易新闻广告 --> <#--右边模块结构--> <#--评论模块结构--> <#--引用模块结构--> <#--博主发起的投票-->
 
 
 
 
 
 
 
 
 
 
 
 
 
 

页脚

网易公司版权所有 ©1997-2017