word VBA 代码

1、vba_1基本入门代码集 by daode1212 2010-10-20sub msg_01()消息框:msgbox 我们将成为vba高手!end subsub msg_02()消息框,换行:msgbox 我们将成为: & vbcrlf & vba高手! & vbcr & vbs高手! & vblf & asp高手!end subsub msg_03()消息框,双引号:msgbox 我们将成为vba高手! & vbcr & chr(34) & -专家级的高手! & chr(34)end subsub msg_04()消息框,当前时间:msgbox 新的长征起步于: & vbcr & nowms

2、gbox 新的vba高手诞生于: & vbcr & year(now) & vbcr & month(now) & vbcr & day(now)msgbox 当前日期: & datemsgbox 当前时间: & timemsgbox 当前时钟(秒): & timermsgbox 星期(星期日:1,星期一:2): & weekday(now)msgbox datediff(d, date, 1-10-2020) 距2010-01-10的天数=字母所表示的意义= yyyy 年 q 季度 n 月 y 一年的日数 d 日 w 一周的日数 ww 周 h 小时 m 分钟 s 秒=msgbox datea

3、dd(yyyy, 50, 01-10-1960) 加了50年的日子仅加上100个星期(700天):msgbox date + 7 * 100 再过100个星期是什么日子end subsub msg_05()消息框,数学计算:msgbox 9*8+36/4-sqr(81)= & vbcr & 9 * 8 + 36 / 4 - sqr(81)msgbox 27的立方根= & vbcr & 27 (1 / 3)作业:计算常用几何图形的周长棱长面积体积；end subsub msg_06()消息框,当前应用程序路径:msgbox 当前应用程序路径: & vbcr & application.pathe

4、nd subsub msg_07()消息框,当前文件路径:msgbox 当前xls路径: & vbcr & thisworkbook.pathend subsub msg_08()消息框,当前工作簿所有工作表:for each x in thisworkbook.sheets s = s & x.name & nextmsgbox 当前工作簿所有工作表: & vbcr & send subsub msg_09()消息框,添加五个工作表,显示当前工作簿所有工作表:sheets.add , , 5for each x in thisworkbook.sheets s = s & x.name &

5、nextmsgbox 当前工作簿所有工作表与图表: & vbcr & send subsub msg_10()消息框,求自然数1,2,3,.,2010之和for i = 1 to 2010s = s + inextmsgbox 自然数1,2,3,.,2010之和是: & s作业:计算1-2010各自然数倒数之和;end subsub 进制转换_11()10 - 16:msgbox hex(255)16 - 10:msgbox &hffend subsub 子串在第几个位置_12()不能找到的:msgbox instr(12345, x) 输出:0找到的位置:msgbox instr(12345

6、, 5) 输出:5找到的位置:msgbox instr(12345, 12) 输出:1从右边向左边搜索,每一次查到的字符位置(位置从左向右计,从1开始)msgbox instrrev(1234512, 2) 输出:7end subsub 左中右_13() mystr = 中国人民保险公司 msgbox left(mystr, 2) msgbox mid(mystr, 3, 4) msgbox right(mystr, 2)end subsub 翻转字符串_14()mystr = 中国人民保险公司msgbox strreverse(mystr)end subsub 替换_15() mystr =

7、 中国人民,保险公司 逗号换成换行: out = replace(mystr, , vbcr) msgbox outend subsub input01()输入框:s = inputbox(请输入你的大名, 姓名输入, daode1212)msgbox s & -你一定会成为vba高手的!end subsub input02()输入框:单元格写入内容:s = inputbox(请输入你的大名, 姓名输入, 项道德)sheet1.cells(1, 1) = smsgbox sheet1 中的 a1 单元格已经写入内容: & send subsub input03()输入框:多个单元格写入内容:s

8、 = inputbox(要在a1:c10中写入什么?, 内容输入, 嫦娥二号)sheet1.range(a1:c10) = smsgbox sheet1 中的 a1:c10 单元格已经写入内容: & send subsub input04()输入框:多个单元格写入内容:s = inputbox(在那一范围内写入内容?, 内容输入, a1:c10)sheet1.range(s) = rndmsgbox sheet1 中的 & s & 单元格已经写入内容: & send subsub input05()输入框:多个单元格写入内容:s = inputbox(在那一范围内写入内容?, 内容输入, a1

9、:c10)for each x in sheet1.range(s) v = int(rnd * 10000) / 100 x.value = vnextmsgbox sheet1 中的 & s & 单元格已经写入内容1-100作业:在一定范围内生成随机整数：60-100作业:在一定范围内生成随机数（两位小数）：0.00-9999.99作业:在一定范围内生成小图案（利用webdings,wingdings字符）end subsub input06()输入框:拆解身份证号:s = inputbox(请输入身份证号码, 内容输入,y = mid(s, 7,

10、4)m = mid(s, 11, 2)d = mid(s, 13, 2)sheet1.cells.clearsheet1.cells(1, 1) = 年sheet1.cells(1, 2) = 月sheet1.cells(1, 3) = 日sheet1.cells(2, 1) = ysheet1.cells(2, 2) = msheet1.cells(2, 3) = dmsgbox 年-月-日 已经分解!作业:设计并拆解考生号;end subsub input07()字符串转变为数组:s = inputbox(请输入二个整数, 内容输入, 33,18)a = split(s, ,)msgbox

11、 a(0) + a(1) 等同于: a(0) & a(1)end subsub input08()字符串转变为数组:s = inputbox(请输入二个整数, 内容输入, 33,18)a = split(s, ,)sheet1.range(b4:b5) = amsgbox cint(a(0) + cint(a(1) 已经转为整数了b6 = cint(a(0) + cint(a(1)作业:输入十个整数,并求出它们的平均数.end subsub input09()生成模拟考生数据:s = inputbox(请输入学生数, 内容输入, 100)z = z & 残叶飘零冷雨飞z = z & 西风得意乱

12、云追z = z & 暮来漫漫梨花落z = z & 晨起茫茫玉宇堆z = z & 洗净铅华出本色z = z & 扫开烟霭露余晖z = z & 梅香不染枝方俏z = z & 雪重难压我自岿c = len(z)sheet1.cells(1, 1) = 姓名sheet1.cells(1, 2) = 语文sheet1.cells(1, 3) = 数学for i = 2 to cint(s) + 1 sheet1.cells(i, 1) = 项 & mid(z, int(c * rnd) + 1, 1) & mid(z, int(c * rnd) + 1, 1) sheet1.cells(i, 2) =

13、40 + int(60 * rnd) sheet1.cells(i, 3) = 10 + int(90 * rnd)nextmsgbox 生成模拟考生数据生成完毕!作业:生成模拟单位员工名册end subsub input10()数组转变为字符串:dim a()s = inputbox(请输入一个整数, 内容输入, 50)c = cint(s)redim a(c)for i = 0 to c a(i) = chr(32 + i)nexts = join(a, )msgbox s作业：测试 chr(-24414 + i)end subsub input11()select-case用法:dim

14、a()s = inputbox(请输入一个英文颜色单词, 内容输入, red)select case scase red msgbox 红case green msgbox 绿case blue msgbox 蓝case black msgbox 黑case white msgbox 白case else msgbox 没有找到!end select作业：给出十二生肖的年龄组，每一组出示10个年龄。end subsub input12()select-case用法(数值范围):dim a()s = inputbox(请输入一个数字, 内容输入, 77)v = cint(s)select cas

15、e vcase 1, 2, 3 msgbox in (1,2,3)case 4 to 10 msgbox in(4 to 10)case 11 to 15, 21 to 25 msgbox in(11 to 15, 21 to 25)case else msgbox 没有找到!end select作业：对考试分数进行分段，判断出：优秀，良好，合格，不及格。end subsub input13()输入框:打印预览与直接打印:s = inputbox(打印预览与直接打印:那一范围内, 内容输入, a1:c10)for each x in sheet1.range(s) v = int(rnd *

16、56) x.interior.colorindex = v 背景色nextsheet1.range(s).columnwidth = 20 列宽sheet1.range(s).rowheight = 16 行高sheet1.range(s).shrinktofit = true 自动缩小字体以适应单元格当字号不变:自动换行,行高自动适应: sheet1.range(s).wraptext = true 自动换行 sheet1.range(s).entirerow.autofit 行高自动适应 sheet1.range(s).borders.linestyle = xlcontinuous 设置

17、单元格边框sheet1.range(s).printpreview 打印预览sheet1.range(s).printout 直接打印作业:生成100教师基本信息表(sheet3),设计好a4模板(sheet1),为每一个教师生成可打印的人事档案(sheet2).end subsub input14()数据的复制:s = inputbox(打印预览与直接打印:那一范围内, 内容输入, a1:c10)for each x in sheet1.range(s) v = int(rnd * 56) x.interior.colorindex = v 背景色next当前区域复制到另一表中:sheet1

18、.range(s).copy sheet2.range(s)分步进行复制与粘贴:sheet1.range(s).copysheet3.activatesheet3.range(g9).selectactivesheet.pasteend subsub input15()二维数组与range()的对应关系:s = inputbox(, 内容输入, 10,5)生成二维数组:dim a()d1 = split(s, ,)(0)d2 = split(s, ,)(1)redim a(d1, d2) 下标都是从0开始的;for i = 1 to d1for j = 1 to d2 a(i, j) = i

19、& , & jnextnext写入表格sheet1中:x = 1: y = 1sheet1.range(cells(x, y), cells(x + d1, y + d2) = a写入另一表格sheet2中:b = sheet1.range(cells(x, y), cells(x + d1, y + d2)sheet2.activatesheet2.range(cells(x, y), cells(x + d1, y + d2) = b作业:将数据区域移到a1为起点,10行,5列.end subvba_4_1自定义菜单与调用自定义过程(by daode1212)2010年10月22日 星期五

20、 下午 4:29vba_4_1自定义菜单与调用自定义过程工具栏浮动：一项目/二个按钮- by daode1212private sub workbook_open()添加菜单end subprivate sub workbook_beforeclose(cancel as boolean)删除菜单end subvba添加按钮菜单sub 添加菜单()on error resume nextapplication.commandbars(mymnu).delete 删除已有菜单set mymnu = application.commandbars.add 添加新菜单with mymnu .visi

21、ble = true 属性值（true为显示） .position = msobartop 将此菜单显示在顶部 .name = mymnuend with=set 子菜单 = mymnu.controls.add(type:=msocontrolpopup) 添加新按钮子菜单.caption = 菜单一set kj = 子菜单.controls.add(type:=msocontrolbutton) 添加新按钮with kj .caption = mcro001 .onaction = thisworkbook.name & !mcro001end with=set kj = 子菜单.cont

22、rols.add(type:=msocontrolbutton) 添加新按钮with kj .caption = mcro002 .onaction = thisworkbook.name & !mcro002end withend subvba删除按钮菜单sub 删除菜单()on error resume nextapplication.commandbars(mymnu).delete 删除已有菜单end subvba_4_1自定义菜单与调用自定义过程工具栏浮动：一项目/二个按钮所用的2模块- by daode1212sub mcro001()msgbox 您好！您选择了菜单一中的mcro

23、001按钮!, 64, 系统提示end subsub mcro002()msgbox 您好！您选择了菜单一中的mcro002按钮!, 64, 系统提示end subvba_4_3(核)加载宏.xla文件制作方法(原创：老外，修改：daode1212)2010年10月22日 星期五 下午 4:53vba_4_3(核)加载宏.xla文件制作方法功能：在工具菜单下添加自定义的项与二个按钮修改：daode1212 在加载宏文件thisworkbook之内： start thisworkbook code moduleoption explicitprivate const c_tag = chipad

24、din c_tag should be a string unique to this add-in.private const c_tools_menu_id as long = 30007& the tool menu idprivate sub workbook_open() workbook_open create a submenu on the tools menu. the submenu has two controls on it.dim toolsmenu as office.commandbarcontroldim toolsmenuitem as office.comm

25、andbarcontroldim toolsmenucontrol as office.commandbarcontrol first delete any of our controls that may not have been properly deleted previously.msgbox 将在工具菜单下添加自定义的项“批量作业”与二个按钮“生成新数据”、“新数据清除”deletecontrols get a reference to the tools menu.set toolsmenu = application.commandbars.findcontrol(id:=c_

26、tools_menu_id)if toolsmenu is nothing then msgbox unable to access tools menu., vbokonly exit subend if create a item on the tools menu.set toolsmenuitem = toolsmenu.controls.add(type:=msocontrolpopup, temporary:=true)if toolsmenuitem is nothing then msgbox unable to add item to the tools menu., vbo

27、konly exit subend ifwith toolsmenuitem .caption = 批量作业 .begingroup = true .tag = c_tagend with create the first control on the new item in the tools menu.set toolsmenucontrol = toolsmenuitem.controls.add(type:=msocontrolbutton, temporary:=true)if toolsmenucontrol is nothing then msgbox unable to add

28、 item to tools menu item., vbokonly exit subend ifwith toolsmenucontrol set the display caption and the procedure to run when clicked. .caption = 生成新数据 .onaction = & thisworkbook.name & !macrotorunone .tag = c_tagend with create the first control on the new item in the tools menu.set toolsmenucontro

29、l = toolsmenuitem.controls.add(type:=msocontrolbutton, temporary:=true)if toolsmenucontrol is nothing then msgbox unable to add item to tools menu item., vbokonly exit subend ifwith toolsmenucontrol set the display caption and the procedure to run when clicked. .caption = 新数据清除 .onaction = & thiswor

30、kbook.name & !macrotoruntwo .tag = c_tagend withend subprivate sub workbook_beforeclose(cancel as boolean) workbook_beforeclose before closing the add-in, clean up our controls. deletecontrolsend subprivate sub deletecontrols() delete controls whose tag is equal to c_tag.dim ctrl as office.commandba

31、rcontrolon error resume nextset ctrl = application.commandbars.findcontrol(tag:=c_tag)do until ctrl is nothing ctrl.delete set ctrl = application.commandbars.findcontrol(tag:=c_tag)loopmsgbox 自定义菜单项已经成功删除。end sub end thisworkbook code module=在加载宏文件之模块内： start module1 code moduleoption explicitsub ma

32、crotorunone() dim s as string s = 宏来源于: & vbcrlf & thisworkbook.fullname msgbox s worksheets(sheet1).range(a1:h20).interior.colorindex = 52 worksheets(sheet1).range(a1:h20) = interior.colorindex = 52 worksheets(sheet1).range(a1:h20).font.size = 5end subsub macrotoruntwo() dim s as string s = 宏来源于: &

33、 vbcrlf & thisworkbook.fullname msgbox s worksheets(sheet1).range(a1:h20).interior.colorindex = xlnone worksheets(sheet1).range(a1:h20) = worksheets(sheet1).range(a1:h20).font.size = 10 worksheets(sheet1).cells(1, 1) = dog sheets(sheet1).cells(2, 1) = pig sheets(1).cells(3, 1) = catend sub end modul

34、e1 code modulevba_4_2自定义菜单与调用自定义过程(by daode1212)2010年10月22日 星期五 下午 4:32vba_4_2自定义菜单与调用自定义过程主菜单（帮助之前位）：一项目/二个按钮- by daode1212private sub workbook_open() addtoolbar addmenuend subprivate sub workbook_beforeclose(cancel as boolean) uninstallend subsub addtoolbar()dim foundflag as boolean=增加工具栏中的按钮=foun

35、dflag = falsefor each ct in application.commandbars(standard).controls debug.print ct.caption if ct.caption mymenu：我的自定义菜单 then else foundflag = true end ifnextif foundflag = false then set newitem = application.commandbars(standard).controls.add(type:=msocontrolbutton, id:=1, before:=1) -工具栏名称-类型 -

36、按钮-id为1自定义-位置- with newitem .style = msobuttoniconandcaption 同时显示图标和说明 .style = msobuttonicon 仅显示按键图标 .caption = 显示选中的区域地址(&a) 为按键写文字说明 .onaction = showabout 指定工作的宏 .faceid = 459 end withend ifend subsub addmenu()dim foundflag as boolean=增加菜单栏中的新栏目=foundflag = falsefor each ct in application.command

37、bars(worksheet menu bar).controls debug.print ct.caption if ct.caption 我的自定义菜单(&a) then else foundflag = true end ifnextif foundflag = false then set newmenu = application.commandbars(worksheet menu bar).controls.add(type:=msocontrolpopup, id:=1, before:=10) -工具栏名称-类型 -按钮-id为1自定义-位置- with newmenu .c

38、aption = 我的自定义菜单(&a) 为按键写文字说明 .controls.add type:=msocontrolpopup, id:=1 再加入一层表单 =加这个按键就不判断了，直接加，今后有扩展再另做方法 set aboutmenu = .controls.add(type:=msocontrolbutton, id:=1) 下拉菜单也是按钮 with aboutmenu .caption = 显示选中的区域地址(&a) .style = msocontroliconandcaption .onaction = showabout .faceid = 459 .begingroup

39、= true 画上一线条 end with set nuinstallmenu = .controls.add(type:=msocontrolbutton, id:=1) with nuinstallmenu 复原 .caption = 卸载自定义菜单(&u) .style = msocontroliconandcaption .onaction = uninstall .faceid = 330 end with end withend ifend subvba_4_2自定义菜单与调用自定义过程主菜单（帮助之前位）：一项目/二个按钮的二个模块代码- by daode1212sub show

40、about()msgbox selection.addressend subsub uninstall()=卸载=if msgbox(你确认要卸载我的自定义菜单吗？, vbokcancel + vbquestion, yidie提醒您：) = vbok then application.commandbars(cell).reset application.commandbars(worksheet menu bar).reset application.commandbars(standard).reset msgbox 菜单已复原！, vbokonly + vbinformation, y

41、idie提醒您：else msgbox 卸载操作已取消, vbokonly + vbinformation, yidie提醒您：end ifend subvba_word常用的一些代码片断(by daode1212)2010年12月01日 星期三 下午 7:09sub 获取行中图形宽度与高度()for each x in thisdocument.inlineshapes x.select msgbox x.width msgbox x.heightnextend subsub 获取图形名称与宽度与高度()for each x in thisdocument.shapes x.select m

42、sgbox x.name msgbox x.width msgbox x.heightnextend subsub 获取段落文本含表格中内容()for each x in thisdocument.paragraphs t0 = x.range.text t1 = replace(t0, chr(13), ) t = replace(t1, chr(7), ) msgbox len(t) & : & tnextend subsub 读取表格中各单元格内容()for each x in thisdocument.tables cc = x.columns.count rc = x.rows.count for i = 1 to rc for j = 1 to cc box = x.cell(i, j).range.text v = replace(box, chr(7), ) msgbox v next nextnextend subsub 读取段落中的第一个单词与最后一个单词()thisdocument.p