EXCELVBA实用代码收集解析

四、Word vba常用语句100句

1、系统参数

(01) Printer „获取当前打印机

(02) '当前应用程序文档的高度

(03) „当前应用程序文档的宽度

(04) „获取Word版本号和编译序号

(05) n „当前应用程序名

(06) tSaveFormat '返回空字符串，表示Word文档

(07) yRecentFiles '返回是否显示最近使用的文档的状态

(08) '返回当前打开的文档数

(09) „返回当前可用的字体数

(10) „返回当前文档的水平位置

(11) me '返回当前文档名，包括所在路径

'返回当前文档路径

„获得文件的相对路径

(12) me '返回文档标准模板名称及所在位置

(13) '返回最近打开的文档数目

(14) yRegion '返回应用程序所在的地区代码

(15) skSpace „返回应用程序所在磁盘可用空间

(16) ntalResolution '返回显示器的水平分辨率

(17) alResolution '返回显示器的垂直分辨率

(18) geDesignation '返回系统所使用的语言

(19) processorInstalled „返回系统是否安装了数学协处理器

(20) ingSystem „返回当前操作系统名

(21) sorType '返回计算机处理器名

(22) n „返回操作系统的版本号

(23) '返回应用程序所使用的模板数

(24) me '返回应用程序用户名

(25) n „返回应用程序的版本号

2、Documents/Document对象

(26) me '返回当前文档采用的模板名及模板所在位置

(27) '返回当前文档中的书签数

(28) '返回当前文档的字符数

(29) me „返回当前文档的代码名称

(30) „ 返回当前文档中的评论数

(31) '返回当前文档中的尾注数

(32) '返回当前文档中的域数目

(33) „返回当前文档中的脚注数

(34) me '返回当前文档的全名及所在位置

(35) sword '当前文档是否有密码保护

(36) '返回当前文档中的链接数

(37) '返回当前文档中的索引数

(38) '返回当前文档中项目编号或项目符号数

(39) '返回当前文档中使用的列表模板数

(40) '返回当前文档中的段落数

(41) rd=XXX '设置打开文件使用的密码

(42) ly '获取当前文档是否为只读属性

(43) '当前文档是否被保存

(44) '当前文档中的节数

(45) „当前文档中的语句数

(46) '当前文档中的形状数 ,图形？

(47) '当前文档中的样式数

(48) „当前文档中的表格数

(49) „返回当前文档中的引文目录数

(50) „返回当前文档中引文目录类别数

(51) „返回当前文档中的目录数

(52) '返回当前文档中的图表目录数

3、Paragraphs/Paragraph对象

(53) '返回所选区域的段落数

(54) '返回所选区域中的第一段

(55) aphs(1).LeftIndent '返回当前文档中第一段的左缩进值

(56) aphs(1).LineSpacing '返回当前文档中第一段的行距

(57) aphs(1).OutlineLevel „返回或设置当前文档中第一段的大纲级别

.OutlineLevel = wdOutlineLevel2 „2级

.OutlineLevel = wdOutlineLevel3 „3级

(58) aphs(1).RightIndent „返回当前文档中第一段的右缩进量

(59) aphs(1).SpaceBefore '返回当前文档中第一段的段前间距

(60) aphs(1).SpaceAfter „返回当前文档中第一段的段后间距

(61) aphs(1). '返回当前文档中第一段的内容

(62) aphs(1).cal '返回当前文档中第一段应用的样式名

(63) aphs(1).ption '返回当前文档中第一段所应用样式的详细描述

(64) aphs(1). '返回当前文档中第一段所应用样式的字体名

(65) aphs(1).rEast '返回或设置一种东亚字体名

(66) aphs(1). '返回或设置当前文档中第一段所应用样式的字体大小

(67) aphs(1).g '返回或设置字符间距

(68) '所选区域的字数 Sentences对象

(69) (1) '所选区域中的第一句的内容 Words对象

(71) (1).Select '选择当前文档中的第一个词

(72) (1).InsertAfter "我爱你！" '在当前文档中的第一个词后插入“我爱你”

4、Characters对象

(73) '当前文档中所选区域的字符数

(74) aphs(1).ParagraphAfter'在当前文档的第一段之后插入一个新段落

5、Sections/Section对象

(75) '当前文档的第一节

(76) Margin '当前文档第一节所在页的底边距

(77) rgin '当前文档第一节所在页的左边距

(78) argin '当前文档第一节所在页的右边距

(79) gin '当前文档第一节所在页的顶边距

(80) ize '返回或设置当前文档第一节所在页的大小

(81) ight '返回或设置当前文档第一节所在页的高度

(82) dth '返回或设置当前文档第一节所在页的宽度

(83) Range:=myRange '在当前文档中添加新节

(84) (2) '当前文档中的第二节

(85) After "文档结束！" '在当前文档中最后一节的结尾添加文字“文档结束！”

6、Range对象

(86) (Start:=0, End:=10) '表示当前文档前10个字符所组成的一个Range对象

(87) Set myRange = (Start:=aphs(2)., _

End:=aphs(4).) '将当前文档第2段至第4段设置为一个Range对象

(88) aphs(1). '复制当前文档中的第一段

(89)

'复制所选内容到新文档中

(90) rks("Book1").Copy Name:="Book2" '将Book2书签复制Book1书签标记的位置

(91) What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=4 '将所选内容移至文档中的第4行

(92) What:=wdGoToTable, Which:=wdGoToNext '将所选内容移至下一个表格的第1个单元格

(93) rmat '为所选内容套用格式

(94) = "Arial" '将当前文档的字体设置为斜体

(95) '将当前文档中的内容删除其它

(96) '添加一个新文档

(97) Set myTable = (, 2, 2) '在当前文档所选区域添加一个2行2列的表格

7、文件读写

(98) Open "C:" For Input As #1 '打开一个用于输入的文件并令其编号为1

(99) Line Input #1, TextLine '读取被打开用于输入且编号为1的文件

(100) Close #1 '关闭编号为1的文件

一、新建Word引用

需要首先创建一个对 Word Application 对象的引用。在VBA中，工具-引用，选取“MicroSoft Word

11.0 Object Library”。

方法一、New ation

Dim Wordapp As ation

Set Wordapp = ation

e = True '可见

'Updating =False '屏幕刷新

Dim WordD As nt '定义word类

Set WordD = '新建文档

„Set WordD = (filename) '打开文档

……

'关闭文档

Set WordD = Nothing

'退出Word对象

方法二、CreateObject

Dim WordApp As Object

Set WordApp =CreateObject("ation") '新建Word对象

„后续操作及退出一样……

方法三、GetObject

文件已打开的情况下，使用：SetWordD=GetObject(filename)，可建立对文档的引用，如果文件没有打开，则还需要先用方法一或二来操作。

至于方法一和方法二的区别，在网上询问了一下，大师们的回答是：

方法一：前期绑定,好处是在对象后输入句点可以给出快速提示，因为需要先引用对象，所以容易出现版本兼容问题。

方法二：后期绑定，没有提示，根据运行代码机器上对象的版本创建对象，兼容性好。

提示：有时二者有较大区别，可论坛搜索字典对象，建议编写代码时使用前期绑定，发布时使用后期绑定。

二、认识Word的结构

Excel有：

ation ‟Excel引用

ation. Workbooks ‟工作簿

ation. （1） ‟工作表

工作表下是Range，区域；Cells(row,col)，单元格

Word有:

ation

nts ‟文档

文档下有字符、单词、句子、段落和节。字符组成单词，单词组成句子，句子组成段落。此外，每个文档具有一个包含一个或多个节的 Sections 集合，每一个节都有一个包含该节页眉和页脚的HeadersFooters 集合。

Characters(index)

Words(index)

Sentences(index)

Paragraphs(index)

Sections(index)

前三个返回Range对象，能直接使用任何区域属性或方法修改该Range 对象。后面二个返回该集合的单个成员，而不是 Range 对象，不能直接使用区域属性或方法。如下使用例子：Words(1)后面直接.Copy，而.Paragraphs(1)和.Copy之间多了一个Range。

(1).Copy

aphs(1).

Characters：字符，ces(1).，第一句的字符总数。

Words：单词，对于英文来说是二个空格之间的字母加空格，对于中文，一个标点符号，一个汉字，或一个词（按照微软的输入法中的词组定义？）。（感觉不是很可靠？）

Sentences：句子，以句号结束？感觉也不是一个很可靠的范围，感觉还是字符、段落、节，控制起来靠谱一些。

Range 对象表示文档中的一个连续范围，由一个起始字符位置和一个终止字符位置定义。这个连续范围可以小到一个插入点，大到整个文档。

Dim rngPa As Range

Set rngPa =ActiveDocument. Characters (1) „第一个字符

Set rngPa = ( _

Start:=aphs(1)., _

End:=aphs(4).) „第1段头到第4段尾

Set rngPa = (Start:=0,End:=10) „当前文档前10个字符

选定，我觉得用处不大，原因就是为什么要选中呢？能操作就直接操作，不能的话，就选中吧（他可以说是没办法的办法）。

range对象的赋值：(包括任意的对象，Set是对对象赋值的标准语句)

set a=b

和变量的赋值：a=1不一样

三、通过录制宏生成代码

有了对Word基本结构的认识，想操作这些对象应该使用什么方法、修改哪些属性？不知道就“录制宏”。录制宏是我们认识未知对象的很好方法之一，通过宏录制器将操作译成Word的 Visual

Basic 代码，再根据需要修改代码。Word中录制与Excel不同的是，不能使用鼠标移动光标或

选中一行，只能使用键盘来移动，或用Shift+方向键来选中。以下几句话就是键盘的：上、下、左、右、Home、End、Shift+左选中5个字符、Shift+右选中5个字符。

Unit:=wdLine, Count:=1

wn Unit:=wdLine, Count:=1

ft Unit:=wdCharacter, Count:=1

ght Unit:=wdCharacter, Count:=1

y Unit:=wdLine

Unit:=wdLine

ft Unit:=wdCharacter, Count:=5, Extend:=wdExtend

ght Unit:=wdCharacter, Count:=5, Extend:=wdExtend

录制的宏使用 Selection 属性返回 Selection 对象。即：录制的宏总是以Selection.开头的，如上。要想使用这个Selection.，有时候我们就不得不先对特定的对象.Select，选中。

当然，Selection是一个Range，Characters、Words、Sentences也是Range，Paragraphs(n). Range,

Sections(2). Range也是Range，那我们就可以将Selection.后面的语句嫁接到前面这些Range之后，就不用先.Select了。

录制的宏，通过嫁接或者复制到EXCEL VBA之后，有的运行会出错，此时应检查以下几项：

1、第一项中要求的“引用”建立了没？

2、利用VBA提醒功能检查语句。VBA编辑过程中，通常在打下. 之后（需要前期绑定？），该对象所有的方法、属性都会显示出来，利用这个特点，可以检查录制的宏，能否嫁接到需要操作的对象之后。提示里有就能，没有就不能。

3、部分转换函数，Word VBA里有，Excel VBA里可能没有，遇到这样的情况，也可能出错。

例：

aphs(1).ineIndent = CentimetersToPoints(0.35)

ineIndent = CentimetersToPoints(0.35)是“首行缩进2字符”操作录制的，嫁接后，运行出错，按方法2检查：.ineIndent能用在Range之后，那么就是CentimetersToPoints(0.35)出问题了？这显然是一个函数，字面意思是“厘米转换成点数”，（录制时我明明输入的是“2字符”，录下来咋成了厘米为单位呢？）那是否是Excel VBA里没有这个函数呢？（我不知道），将=后面直接改为数字运行通过，最后试下来=20大约相当于5号字的“首行缩进2字符”。（这个20，就是20Points？0.35cm=20 Points？）

（有人可能会说这样的办法太笨，有什么好办法请告知。先谢过！）

四、Word vba常用语句100句

1、系统参数

(01) Printer „获取当前打印机

(02) '当前应用程序文档的高度

(03) „当前应用程序文档的宽度

(04) „获取Word版本号和编译序号

(05) n „当前应用程序名

(06) tSaveFormat '返回空字符串，表示Word文档

(07) yRecentFiles '返回是否显示最近使用的文档的状态

(08) '返回当前打开的文档数

(09) „返回当前可用的字体数

(10) „返回当前文档的水平位置

(11) me '返回当前文档名，包括所在路径

'返回当前文档路径

„获得文件的相对路径

(12) me '返回文档标准模板名称及所在位置

(13) '返回最近打开的文档数目

(14) yRegion '返回应用程序所在的地区代码

(15) skSpace „返回应用程序所在磁盘可用空间

(16) ntalResolution '返回显示器的水平分辨率

(17) alResolution '返回显示器的垂直分辨率

(18) geDesignation '返回系统所使用的语言

(19) processorInstalled „返回系统是否安装了数学协处理器

(20) ingSystem „返回当前操作系统名

(21) sorType '返回计算机处理器名

(22) n „返回操作系统的版本号

(23) '返回应用程序所使用的模板数

(24) me '返回应用程序用户名

(25) n „返回应用程序的版本号

2、Documents/Document对象

(26) me '返回当前文档采用的模板名及模板所在位置

(27) '返回当前文档中的书签数

(28) '返回当前文档的字符数

(29) me „返回当前文档的代码名称

(30) „ 返回当前文档中的评论数

(31) '返回当前文档中的尾注数

(32) '返回当前文档中的域数目

(33) „返回当前文档中的脚注数

(34) me '返回当前文档的全名及所在位置

(35) sword '当前文档是否有密码保护

(36) '返回当前文档中的链接数

(37) '返回当前文档中的索引数

(38) '返回当前文档中项目编号或项目符号数

(39) '返回当前文档中使用的列表模板数

(40) '返回当前文档中的段落数

(41) rd=XXX '设置打开文件使用的密码

(42) ly '获取当前文档是否为只读属性

(43) '当前文档是否被保存

(44) '当前文档中的节数

(45) „当前文档中的语句数

(46) '当前文档中的形状数 ,图形？

(47) '当前文档中的样式数

(48) „当前文档中的表格数

(49) „返回当前文档中的引文目录数

(50) „返回当前文档中引文目录类别数

(51) „返回当前文档中的目录数

(52) '返回当前文档中的图表目录数

3、Paragraphs/Paragraph对象

(53) '返回所选区域的段落数

(54) '返回所选区域中的第一段

(55) aphs(1).LeftIndent '返回当前文档中第一段的左缩进值

(56) aphs(1).LineSpacing '返回当前文档中第一段的行距

(57) aphs(1).OutlineLevel „返回或设置当前文档中第一段的大纲级别

.OutlineLevel = wdOutlineLevel2 „2级

.OutlineLevel = wdOutlineLevel3 „3级

(58) aphs(1).RightIndent „返回当前文档中第一段的右缩进量

(59) aphs(1).SpaceBefore '返回当前文档中第一段的段前间距

(60) aphs(1).SpaceAfter „返回当前文档中第一段的段后间距

(61) aphs(1). '返回当前文档中第一段的内容

(62) aphs(1).cal '返回当前文档中第一段应用的样式名

(63) aphs(1).ption '返回当前文档中第一段所应用样式的详细描述

(64) aphs(1). '返回当前文档中第一段所应用样式的字体名

(65) aphs(1).rEast '返回或设置一种东亚字体名

(66) aphs(1). '返回或设置当前文档中第一段所应用样式的字体大小

(67) aphs(1).g '返回或设置字符间距

(68) '所选区域的字数 Sentences对象

(69) (1) '所选区域中的第一句的内容 Words对象

(71) (1).Select '选择当前文档中的第一个词

(72) (1).InsertAfter "我爱你！" '在当前文档中的第一个词后插入“我爱你”

4、Characters对象

(73) '当前文档中所选区域的字符数

(74) aphs(1).ParagraphAfter'在当前文档的第一段之后插入一个新段落

5、Sections/Section对象

(75) '当前文档的第一节

(76) Margin '当前文档第一节所在页的底边距

(77) rgin '当前文档第一节所在页的左边距

(78) argin '当前文档第一节所在页的右边距

(79) gin '当前文档第一节所在页的顶边距

(80) ize '返回或设置当前文档第一节所在页的大小

(81) ight '返回或设置当前文档第一节所在页的高度

(82) dth '返回或设置当前文档第一节所在页的宽度

(83) Range:=myRange '在当前文档中添加新节

(84) (2) '当前文档中的第二节

(85) After "文档结束！" '在当前文档中最后一节的结尾添加文字“文档结束！”

6、Range对象

(86) (Start:=0, End:=10) '表示当前文档前10个字符所组成的一个Range对象

(87) Set myRange = (Start:=aphs(2)., _

End:=aphs(4).) '将当前文档第2段至第4段设置为一个Range对象

(88) aphs(1). '复制当前文档中的第一段

(89)

'复制所选内容到新文档中

(90) rks("Book1").Copy Name:="Book2" '将Book2书签复制Book1书签标记的位置

(91) What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=4 '将所选内容移至文档中的第4行

(92) What:=wdGoToTable, Which:=wdGoToNext '将所选内容移至下一个表格的第1个单元格

(93) rmat '为所选内容套用格式

(94) = "Arial" '将当前文档的字体设置为斜体

(95) '将当前文档中的内容删除其它

(96) '添加一个新文档

(97) Set myTable = (, 2, 2) '在当前文档所选区域添加一个2行2列的表格

7、文件读写

(98) Open "C:" For Input As #1 '打开一个用于输入的文件并令其编号为1

(99) Line Input #1, TextLine '读取被打开用于输入且编号为1的文件

(100) Close #1 '关闭编号为1的文件

五、例子。例中的操作全部是录制，然后嫁接的。

例子：用Excel VBA，将如下Excel表格(考试系统中导出的题库 ),生成如下Word文档

规程名称 题型 题目内容 答案A 答案B 答案C 答案D 正确答案 分值 有否图形

规程1 选择题 题目1…… …… …… …… …… ABCD 2

规程1 判断题 题目2…… 对 2

规程2 选择题 题目3…… …… …… …… …… A 2

规程2 判断题 题目4…… 错 2

规程1

一、选择题

1、题目1…… （ABCD）

A、……

B、……

C、……

D、……

二、判断题

1、题目2…… （对）

规程2

一、选择题

1、题目3…… （A）

A、……

B、……

C、……

D、……

二、判断题

1、题目4…… （错）

Sub ScWordWd()

'将“题库”中的题目，按格式生成Word文档

Dim I As Integer, J As Integer, Zhs As Integer, Xh As Integer, Dls As String

Dim Lr As String, Bt As String, Bt1 As String, Tx As String, Tx1 As String

Dim Lj As String, Wjm As String

Dim AA

Sheets("题库").Select

Zhs = Sheets("题库").

Bt = Cells(2, 1) '标题

Tx = Cells(2, 2) '题型

Xh = 1 '

Dls = 1 '

'Dim WordApp As Object

'Set WordApp = CreateObject("ation") '新建Word对象

Dim Wordapp As ation

Set Wordapp = New ation '新建Word对象

e = True '可见

'Updating = False '屏幕刷新

Dim WordD As nt '定义word类

Set WordD = '新建文档

tory '全选

= "宋体" '字体

= 10 '字号

For I = 2 To Zhs

Bt1 = Cells(I, 1)

aphs(Dls). = "宋体" '字体

aphs(Dls). = 10 '字号

If Len(Trim(Bt1)) > 0 Then

Tx1 = Cells(I, 2)

Lr = Cells(I, 3)

If Bt1 <> Bt Then '标题不同，写标题，居中

If I > 5 Then '

aphs(Dls).After (vbCrLf) '插入回车符，增加一段

Dls = Dls + 1

aphs(Dls).

'Break Type:=wdPageBreak

'aphs(Dls).Break Type:=wdPageBreak '插入分页符，两个都没反应？

Break Type:=wdSectionBreakNextPage '插入分节符（下一页）

aphs(Dls).After (vbCrLf) '插入回车符，增加一段

Dls = Dls + 1

End If

Bt = Bt1

aphs(Dls). = Bt & vbCrLf '写标题

'aphs(Dls).After (vbCrLf) '插入回车符，增加一段

aphs(Dls).OutlineLevel = wdOutlineLevel2 '设置大纲级别，2级

'aphs(Dls).ineIndent =

CentimetersToPoints(0)

aphs(Dls).ineIndent = 0 '取消首行缩进

'aphs(Dls). = "宋体" '字体

'aphs(Dls). = 10 '字号

aphs(Dls).ent =

wdAlignParagraphCenter '居中排列

aphs(Dls). = wdToggle '加粗

Dls = Dls + 1

Xh = 1

End If

If Tx1 <> Tx Then '题型不同，写题型

If Tx1 = "选择题" Then

aphs(Dls). = "一、选择题" '写题型

Else

aphs(Dls).After (vbCrLf) '插入回车符，增加一段

Dls = Dls + 1

aphs(Dls). = "二、判断题" '写题型

End If

Tx = Tx1

aphs(Dls).ent =

=

wdAlignParagraphJustify '左对齐

'aphs(Dls).ineIndent

CentimetersToPoints(0.35) '首行缩进2字符,时能用时不能用，CentimetersToPoints不能被Excel识别？

aphs(Dls).ineIndent = 20 '首行缩进，20大约相当于5号字的2字符

aphs(Dls).After (vbCrLf) '插入回车符，增加一段

aphs(Dls). = wdToggle '加粗

Dls = Dls + 1

Xh = 1

End If

If Tx = "选择题" Then

aphs(Dls). = Xh & "、" & Lr & " （" & Cells(I, 8) & "）"

& vbCrLf '写题目及标准答案

Dls = Dls + 1

aphs(Dls). = "A、" & Cells(I, 4) & vbCrLf '选项A

Dls = Dls + 1

aphs(Dls). = "B、" & Cells(I, 5) & vbCrLf '选项B

Dls = Dls + 1

aphs(Dls). = "C、" & Cells(I, 6) & vbCrLf '选项C

Dls = Dls + 1

If Len(Trim(Cells(I, 7))) > 0 Then

aphs(Dls). = "D、" & Cells(I, 7) & vbCrLf '选项D

Dls = Dls + 1

End If

Xh = Xh + 1

Else

aphs(Dls). = Xh & "、" & Lr & " （" & Cells(I, 8) & "）"

& vbCrLf '写题目及标准答案

Dls = Dls + 1

Xh = Xh + 1

End If

End If

Next I

State = wdWindowStateMinimize '最小化窗口

'Updating = True '屏幕刷新

' '

'Set WordD = Nothing

'Set Wordapp = Nothing

' '退出Word对象

te

End Sub

图片切换

Sub 显示开或关()

If ("Picture 2").Visible = True Then

("Picture 1").Visible = True

("Picture 2").Visible = False

Else

("Picture 2").Visible = True

("Picture 1").Visible = False

End If

End Sub

当前单元格输入数字自动分解

Private Sub Worksheet_Change(ByVal Target As Range)

If > 1 Then Exit Sub

If Len(Target(1, 1)) > 1 Then

Dim oJs As Object

Set oJs = CreateObject("ScriptControl"): ge = "JScript"

Target(1, 2).Resize(1, 254).ClearContents

(1, Len(Target)) = Split(("'" & Target & "'.match(/./g);"), ",")

End If

End Sub

word批量修改图片大小——固定长宽

Sub setpicsize() '设置图片大小

Dim n'图片个数

On Error Resume Next '忽略错误

For n = 1 To 'InlineShapes类型图片

Shapes(n).Height = 400 '设置图片高度为 400px

Shapes(n).Width = 300 '设置图片宽度 300px

Next n

For n = 1 To 'Shapes类型图片

(n).Height = 400 '设置图片高度为 400px

(n).Width = 300 '设置图片宽度 300px

Next n

End Sub

批量修改图片大小——按比例缩放篇

Sub setpicsize() '设置图片大小

Dim n'图片个数

Dim picwidth

Dim picheight

On Error Resume Next '忽略错误

For n = 1 To 'InlineShapes类型图片

picheight = Shapes(n).Height

picwidth = Shapes(n).Width

Shapes(n).Height = picheight * 1.1 '设置高度为1.1倍

Shapes(n).Width = picwidth * 1.1 '设置宽度为1.1倍

Next n

For n = 1 To

'Shapes类型图片

picheight = (n).Height

picwidth = (n).Width

(n).Height = picheight * 1.1 '设置高度为1.1倍

(n).Width = picwidth * 1.1 '设置宽度为1.1倍

Next n

End Sub

批量给图片加边框

Dim i As Integer

For i = 1 To

With Shapes(i)

With .Borders(wdBorderLeft)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth100pt

.Color = wdColorAutomatic

End With

With .Borders(wdBorderRight)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth100pt

.Color = wdColorAutomatic

End With

With .Borders(wdBorderTop)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth100pt

.Color = wdColorAutomatic

End With

With .Borders(wdBorderBottom)

.LineStyle = wdLineStyleSingle

.LineWidth = wdLineWidth100pt

.Color = wdColorAutomatic

End With

. = False

End With

With Options

.DefaultBorderLineStyle = wdLineStyleSingle

.DefaultBorderLineWidth = wdLineWidth100pt

.DefaultBorderColor = wdColorAutomatic

End With

Next i

锁定文件名

Private Sub Workbook_Open()

If <> "三八节.xls" Then

yAlerts = False

End If

End Sub

将数值转换为文本

[程序扩展] 可以将程序代码1和程序代码2略加改动，将一个字符附加到所选单元格的开头。如将

= "'" & 换成=”I”&，则在所选单元格开头添加字符“I”，即可统一单元格开始形式。

[程序代码1]

Sub 数值转换为文本1() '通过添加'号

Dim cell As Range

For Each cell In Selection

If Not mula Then

If Not IsEmpty(cell) Then

= "'" &

End If

End If

Next

End Sub

[程序代码2]

Sub 数值转换成文本2() '只对数字单元格进行操作

Dim cell As Range

For Each cell In Selection

If Not mula Then

If Not IsEmpty(cell) Then

If IsNumeric(cell) Then

= "'" & '可根据需要变换字符

End If

End If

End If

Next

End Sub

[程序代码3]

Sub 数值转换为文本3() '通过格式

Dim cell As Range

For Each cell In Selection

If Not mula Then

If Not IsEmpty(cell) Then

FormatLocal = "@"

End If

End If

Next

End Sub

关闭并保存所有工作簿

Option Explicit

Sub CloseAllWorkbooks()

Dim Book As Workbook

For Each Book In Workbooks

If <> Then

savechanges:=True

End If

Next Book

savechanges:=True

End Sub

关闭工作簿并将它彻底删除

Option Explicit

Sub KillMe()

With ThisWorkbook

.Saved = True

.ChangeFileAccess

Mode:=xlReadOnly

Kill .FullName .Close False

End With

End Sub

A列输出排列组合

Sub pailie()

Dim s As String, x() As String

Dim starttime As Single, endtime As Single

Dim i As Long, j As Integer, k As Integer, Num As Long, n As Integer

Dim ALL(), TEMP1 As Long, TEMP2 As Long, arr() As String

s = InputBox("请输入不重复的字母或数字")

n = Len(s) '元素个数

ReDim x(n - 1)

For i = 1 To n

x(i - 1) = Mid(s, i, 1)

Next

starttime = Timer '开始计时

Num = 1

For i = 1 To n

Num = Num * i '递归计算n！

Next

ReDim arr(1 To Num, 1 To 1)

For i = 1 To Num

ReDim ALL(1 To n) '初始化数组all

ALL(1) = x(0)

TEMP1 = i

For j = 2 To n

TEMP2 = TEMP1 Mod j

TEMP1 = TEMP1 j

If TEMP2 = 0 Then

ALL(j) = x(j - 1) 'temp2为 0则放在最后

Else

For k = j To TEMP2 + 1 Step -1

ALL(k) = ALL(k - 1) ' temp2之后的元素后移一位

Next

ALL(TEMP2) = x(j - 1) 'temp2不为 0 则置于第temp2个元素前

End If

Next

arr(i, 1) = Join(ALL, "") '输出

Next

endtime = Timer

Updating = False

Range("a1").Resize(Num, 1) = arr

Updating = True

MsgBox "共 " & Num & " 种排列！用时 " & endtime - starttime & " 秒！"

End Sub

同薄汇总工作表

Sub mysub()

Updating = False

Dim sh As Worksheet, aa As Long, bb As Long, cc As Long, dd As Long

dd = Sheets("汇总").[IV1].End(1).Column

Sheets("汇总").Range(Cells(2, 2), Cells(65536, dd)).ClearContents

For Each sh In Worksheets

If <> "汇总" Then

bb = Sheets("汇总").[b65536].End(xlUp).Row + 1

aa = sh.[b65536].End(xlUp).Row

cc = sh.[IV1].End(1).Column

((2, 2), (aa, cc)).Copy

Sheets("汇总").Cells(bb, 2).PasteSpecial xlPasteValues

End If

Next sh

Updating = True

End Sub

异薄SHEET1汇总

Private Sub CommandButton2_Click()

Updating = False

Dim i&, LastRow&, Path$, FileName$, TWB$, WB As Workbook

Path = & ""

FileName = Dir(Path & "*.xls")

TWB =

Range("A1:X65536").ClearContents

Do While Len(FileName)

If FileName <> TWB Then

Set WB = (Path & FileName)

With eets(1)

LastRow = .Range("A65536").End(xlUp).Row

If LastRow > 1 Then

.Range("A8:x8").Copy

("汇总").Range("A65536").End(xlUp)(2).PasteSpecial

Paste:=xlValue

End If

End With

yMode = False

True

End If

FileName = Dir()

Loop

Range("A1").Select

Set WB = Nothing

Updating = True

End Sub

异薄汇总工作表

Private Sub CommandButton2_Click()

Updating = False

Dim i&, LastRow&, Path$, FileName$, TWB$, WS As Worksheet, WB As Workbook

Path = & ""

FileName = Dir(Path & "*.xls")

TWB =

Range("A1:X65536").ClearContents

Do While Len(FileName)

If FileName <> TWB Then

Set WB = (Path & FileName)

For Each WS In eets

LastRow = ("A65536").End(xlUp).Row

If LastRow > 1 Then

("A8:x" & LastRow).Copy '复制A8：X列&最后有数据的列

("汇总").Range("A65536").End(xlUp)(2).PasteSpecial

Paste:=xlValue '粘贴到“汇总”表，从下往上数有数据的列的下一列

End If

Next

yMode = False

True

End If

FileName = Dir()

Loop

Range("A1").Select

Set WB = Nothing

Updating = True

End Sub

调用实例

s(1).Show是调用打开对话框

s(5或145).Show是调用另存为对话框，

s(6).Show是删除文档

s(7).Show是页面设置

s(8).Show是打印对话框

s(9).Show是选择打印机对话框

s(12).Show是重排窗口设置对话框

s(17).Show宏对话框

s(23).Show设置打印标题

s(26).Show字体设置对话框

s(27).Show显示选项

s(28).Show保护工作表

s(32).Show重算选项

s(39或192).Show排序

s(40).Show序列选项

s(41).Show模拟运算表

s(42或111).Show单元格格式，选择单元格内容的格式

s(43).Show选择单元格字体的排列格式，横排或竖排等

s(44或134或190).Show字体选择

s(45).Show边框格式设置

s(46).Show对单元格的保护或隐藏选项

s(47).Show列宽设置选项

s(52).Show清除对话框

s(53).Show选择性粘贴对话框

s(54).Show删除对话框

s(55).Show插入对话框

s(61或110).Show定义名称对话框

s(62).Show指定名称

s(63或132).Show定位

s(64).Show查找

s(84).Show设置单元格颜色和图案

s(91).Show分列

s(94).Show取消或隐藏工作表选择对话框

s(95).Show工作区视图等选项

s(103).Show选择要激活哪个工作表对话框

s(108).Show复制图片选项

s(119).Show新建对话框

s(127).Show设置行高

s(130).Show替换对话框

s(137).Show拆分当前窗口

s(161).Show设置图表颜色

s(170或171).Show移动当前窗口

s(191).Show合并计算对话框

s(198).Show单变量求解

s(199).Show选定成组工作表

s(200).Show填充成组工作表

选项按钮输入单元格

Private Sub CommandButton1_Click()

For Each sp In ls '在窗体(me)中的Frame1内的所有控件进行遍历

If sp Then Sheet1.[a3] = n '如果某个被选中，则将该选项按钮的Caption写入工作表Sheet1的a3单元格

Next

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '1. 直接关闭窗体应是不用保存的了(或给个提示,是否要保存)

If MsgBox("是否保存选项", vbYesNo) = vbOK Then

For Each sp In ls

CommandButton1_Click

Next

End If

End Sub

获取屏幕分辨率

Sub fenbianlv()

strComputer = "."

Set objWMIService = GetObject("winmgmts:" _

& "{impersonationLevel=impersonate}!" & strComputer & "rootcimv2")

Set colSettings = ery _

("Select * from Win32_DesktopMonitor")

For Each objScreen In colSettings

MsgBox "屏幕高：" & Height & vbCrLf _

& "屏幕宽：" & Width

Next

End Sub

不输入显示灰色字体，输入显示输入内容

Sheet1:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Call M

End Sub

模块：

Sub M()

If Range("B3") = "" Then

Range("B3") = "请在此处输入姓名"

Range("B3").ndex = 16

ElseIf Range("B3") <> "请在此处输入姓名" And Range("B3") <> "" Then

Range("B3").ndex = 1

End If

End Sub

点击单元格自动求和

Sheet1:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If = 3 Then

= (Range(Cells(4, ),

)))

End If

End Sub

根据第一个工作表A列内容自动创建相应工作表

Sub CreatMySheets()

Dim m As Range, str As String, created As Boolean

On Error GoTo ErrorHandler

For Each m In Range([A1], Cells(lCells(xlLastCell).Row(), 1))

str =

If str <> "" Then

If Not created Then

After:=Worksheets()

End If

created = False

= str

End If

Next m

On Error GoTo 0

Set m = Nothing

yAlerts = False

If created Then

Cells(65536,

yAlerts = True

Exit Sub

ErrorHandler:

created = True

Resume Next

End Sub

Private Sub TextBox1_Change()

If TextBox1 <> "S" And TextBox1 <> "N" And TextBox1 <> "E" And TextBox1 <> "W" Then

MsgBox "错误的输入,即将被删除"

TextBox1 = ""

End If

End Sub

定义变量：

Dim 变量名 As 数据类型

Option Explict作为第一句语句强制声明所有变量

Dim或Static语句 本地变量（作用此过程）

Dim或Prvate语句 模块作用域下的变量（作用此模块）

Public 公有变量（作用所有模块）

定义常量：

Const 常量名 As 数据类型 ＝ 常量的值

声明数组

Dim/Public 数组名 (a to b) as 数据类型

调用函数

前面加上eetfunction

在VBA里使用counta函数则代码为： (range("a1:a10"))

Sub myabs()

a = InputBox("请输入数值：", "提示")

labs = Abs(a)

MsgBox "你输入的值的绝对值为:" & labs

End Sub

闪动字符

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub t()

Dim str$, i%

str = "祝你生日快乐☆" & "祝你生日快乐☆"

For i = 1 To Len(str)

[a1] = Mid(str, i, 1)

With [a1].Font

.Size = 18

.Color = vbRed

End With

Sleep 500

Next i

End Sub

截取指定字符前内容

Sub m()

Dim eR&

eR = [A65535].End(xlUp).Row

For i = 2 To eR

Ar = Split(Cells(i, 1), [C2]) '按指定符号取值

Cells(i, 2) = Ar(0)

Next i

End Sub

按颜色汇总

Public Function COLOR(ByVal X As Range, Y)

For Each I In X

If ndex = Y Then

COLOR = COLOR + I

End If

Next I

End Function

'统计红色,输入：=COLOR(a1:b10,3)

'统计蓝色,输入：=COLOR(a1:b10,5)

如果打开文件自动屏蔽,把屏蔽代码放入Workbook_Open事件中， 值为False:

Private Sub Workbook_Open()

„„

End Sub

如果想自动恢复,把恢复代码放入Workbook_BeforeClose事件中，值为True：

Private Sub Workbook_BeforeClose(Cancel As Boolean)

„„

End Sub

dBars(1).Controls("工具(&T)").Controls("宏(&M)").Enabled = False '工具-宏变成灰色，如忘了变回来，工具-自定义-工具栏选项-工作表菜单栏-重新设置即可

dBars("ply").Controls("查看代码(&V)").Enabled = False '右键工作表标签“查看代码”为灰色

dBars("Document").Controls("查看代码(&V)").Enabled = False '右键工作薄“查看代码”为灰色

'常用的屏蔽代码：

dBars("Worksheet Menu Bar").Enabled = False '屏蔽菜单栏

yFormulaBar = False '屏蔽编辑栏

yStatusBar = False '屏蔽状态栏

下面任选一组即可，不可同时出现。

dBars("Standard").Visible = False '屏蔽常用工具栏，右键可选

dBars("Formatting").Visible = False '屏蔽格式工具栏，右键可选

dBars("Standard").Enabled = False '去除常用工具栏，右键也删掉

dBars("Formatting").Enabled = False '去除格式工具栏，右键也删掉

dBars("Toolbar list").Enabled = False '屏蔽右键工具栏

dBars("cell").Enabled = False '屏蔽单元格右键单击

dBars("Column").Enabled = False '屏蔽列右键单击

dBars("Row").Enabled = False '屏蔽行右键单击

e = False '应用程序的辅助的可见

eCustomize = True '去除右键工具栏中的“自定义”

yHeadings = False '屏蔽行号列标

yWorkbookTabs = False '屏蔽工作表标签

yVerticalScrollBar = False '屏蔽垂直滚动条

yHorizontalScrollBar = False '屏蔽水平滚动条

dBars("ply").Enabled = False '屏蔽工作表标签右键单击

dBars("Visual basic").Enabled = False '屏蔽应用程序的<命令块>("Visual

basic" )的激活

"%{f11}", " " '屏蔽组合键ALT+F11，%代表ALT

"%{F11}" '解除屏蔽ALT+F11

"%{f8}", " " '屏蔽组合键ALT+F8

"%{f8}" '解除屏蔽ALT+F8

"^{f11}", "VBEdit" '屏蔽组合键Ctrl+F11,插入宏表，^代表Ctrl

"^{f11}" '恢复组合键Ctrl+F11,插入宏表

"^f", " " '屏蔽组合键Ctrl+F，查找

"^h", " " '屏蔽组合键Ctrl+H，替换

"^{Break}", " " '屏蔽CTRL+Break中断

"^{Break}" '解除CTRL+Break中断

'屏蔽“菜单”中的项：

dBars(1).Controls("文件(&F)").Enabled = False '屏蔽文件菜单

dBars(1).Controls("编辑(&E)").Enabled = False '屏蔽编辑菜单

dBars(1).Controls("视图(&V)").Enabled = False '屏蔽视图菜单

dBars(1).Controls("插入(&I)").Enabled = False '屏蔽插入菜单

dBars(1).Controls("格式(&O)").Enabled = False '屏蔽格式菜单

dBars(1).Controls("工具(&T)").Enabled = False '屏蔽工具菜单

dBars(1).Controls("数据(&D)").Enabled = False '屏蔽数据菜单

dBars(1).Controls("窗口(&W)").Enabled = False '屏蔽窗口菜单

dBars(1).Controls("帮助(&H)").Enabled = False '屏蔽帮助菜单

'屏蔽“菜单”中的子项：

dBars(1).Controls("编辑(&E)").Controls("填充(&I)").Enabled = False '屏蔽“编辑”菜单中的“填充”项

dBars(1).Controls("工具(&T)").Controls("选项(&O)...").Visible = False '去除工具-选项

dBars(1).Controls("工具(&T)").Controls("选项(&O)...").Enabled = False '工具-选项变灰色

'禁用粘贴:

dBars("Cell").Controls("粘贴(&P)").Enabled = False '禁用右键粘贴

dBars("Cell").Controls("选择性粘贴(&S)...").Enabled = False

dBars(1).Controls("编辑(&E)").Controls("粘贴(&P)").Enabled = False

dBars(1).Controls("编辑(&E)").Controls("选择性粘贴(&S)...").Enabled = False

dBars(1).Controls("编辑(&E)").Controls("office 剪贴板(&B)...").Enabled = False

dBars(3).Controls("粘贴(&P)").Enabled = False

eCustomize = True

dBars(1).Controls("工具(&T)").Controls("自定义(&C)...").Enabled = False

"^v", "" '禁用键盘"Ctrl+V"

"^v" '恢复键盘"Ctrl+V"

eAskAQuestionDropdown = True '去除工作表右上角的帮助栏

dBars("Reviewing").Visible = False '屏蔽审阅

dBars("Formula Auditing").Visible = False '屏蔽公式审核

dBars("Control Toolbox").Visible = False '屏蔽控件工具箱

dBars("Stop Recording").Visible = False '屏蔽录制宏

dBars("Forms").Visible = False '屏蔽窗体

dBars("Drawing").Visible = False '屏蔽绘图

屏蔽/解除整段代码：

视图-》工具栏-》编辑，选中代码，然后在编辑的工具栏里“设置注释块和“解除注释块”按钮

CancelKey = xlDisabled '应用程序的EnableCancelKey=完全禁用“取消”键捕获功能

CancelKey = xlInterrupt '应用程序的EnableCancelKey=中断当前运行程序，用户可进行调试或结束程序的运行

单列点击单元格弹出日历

Private Sub Calendar1_Click()

Dim MyDay As Date

ActiveCell =

Mydate =

'MsgBox Mydate

e = 0

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If = 2 And > 0 Then

If IsDate(Target) Then

= Target

Else

End If

e = -1

= +

= + Cells(, 3).Left

Else

e = 0

End If

End Sub

多列点击单元格弹出日历

Private Sub Calendar1_Click()

Dim MyDay As Date

ActiveCell =

Mydate =

'MsgBox Mydate

e = 0

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If = 2 Or = 4 Or = 5 Or = 7 And > 0

Then

If IsDate(Target) Then

= Target

Else

End If

e = -1

= +

= + Cells(, 3).Left

Else

e = 0

End If

End Sub

快速选取带颜色单元格

Private Sub CommandButton1_Click()

Dim a, c As Range

For Each a In Range("A1:J22")

If ndex <> xlNone Then

If c Is Nothing Then

Set c = a

Else

Set c = Union(c, a)

End If

End If

Next

If Not c Is Nothing Then

End If

End Sub

提取test1与test2中A列数据相同的到sheet2

Sub 提取test1与test2中A列数据相同的到sheet2()

Dim cnn As Object, SQL$

Set cnn = CreateObject("tion")

"Provider=.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" &

& ""

SQL = "select a.* from [Sheet1$] a,[Excel 8.0;hdr=no;Database=" & me &

"].[Sheet1$a1:a" & [a65536].End(xlUp).Row & "] b where a.f1=b.f1"

With Sheets("Sheet2")

.ontents

.Range("a1").CopyFromRecordset e(SQL)

End With

Set cnn = Nothing

End Sub

提取test1与test2中A列数据不相同的到sheet3

Sub 提取test1与test2中A列数据不相同的到sheet3()

Dim cnn As Object, SQL$

Set cnn = CreateObject("tion")

"Provider=.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" &

& ""

SQL = "select a.* from [Sheet1$] a left join [Excel 8.0;hdr=no;Database=" & me &

"].[Sheet1$a1:a" & [a65536].End(xlUp).Row & "] b on a.f1=b.f1 where b.f1 is null"

SQL = SQL & " union all select a.* from [Excel 8.0;hdr=no;Database=" & me &

"].[Sheet1$a1:b" & [a65536].End(xlUp).Row & "] a left join [Sheet1$] b on a.f1=b.f1 where b.f1 is null"

With Sheets("Sheet3")

.ontents

.Range("a1").CopyFromRecordset e(SQL)

End With

Set cnn = Nothing

End Sub

提取test1与test2中A列数据叠加去除重复数据的到sheet4

Sub 提取test1与test2中A列数据叠加去除重复数据的到sheet4()

Dim cnn As Object, SQL$

Set cnn = CreateObject("tion")

"Provider=.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" &

& ""

SQL = "select * from [Sheet1$] union select * from [Excel 8.0;hdr=no;Database=" &

me & "].[Sheet1$a1:b" & [a65536].End(xlUp).Row & "]"

With Sheets("Sheet4")

.ontents

.Range("a1").CopyFromRecordset e(SQL)

End With

Set cnn = Nothing

End Sub

Sub 提取test1与test2中A列数据不相同的到sheet3()

Dim cnn As Object, SQL$

Set cnn = CreateObject("tion")

"Provider=.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" &

& ""

SQL = "select a.* from [Sheet1$a1:c] a left join [Excel 8.0;hdr=no;Database=" & me &

"].[Sheet1$a1:a" & [a65536].End(xlUp).Row & "] b on a.f1=b.f1 where b.f1 is null"

SQL = SQL & " union all select a.* from [Excel 8.0;hdr=no;Database=" & me &

"].[Sheet1$a1:c" & [a65536].End(xlUp).Row & "] a left join [Sheet1$a1:c] b on a.f1=b.f1 where b.f1 is null"

With Sheets("Sheet3")

.ontents

.Range("a1").CopyFromRecordset e(SQL)

End With

Set cnn = Nothing

End Sub

Sub 提取test1与test2中A列数据叠加去除重复数据的到sheet4()

Dim cnn As Object, SQL$

Set cnn = CreateObject("tion")

"Provider=.4.0;Extended Properties='Excel 8.0;hdr=no';Data Source=" &

& ""

SQL = "select * from [Sheet1$a1:c] union select * from [Excel 8.0;hdr=no;Database=" &

me & "].[Sheet1$a1:c" & [a65536].End(xlUp).Row & "]"

With Sheets("Sheet4")

.ontents

.Range("a1").CopyFromRecordset e(SQL)

End With

Set cnn = Nothing

End Sub

显示宏表

Sub test()

Dim sh As Worksheet

For Each sh In Excel4MacroSheets

If Not e Then e = 1

Next

End Sub

隐藏宏表

Sub test()

Dim sh As Worksheet

For Each sh In Excel4MacroSheets

e = 2

Next

End Sub

程序流程控制—>if语句

if—then语句（如果，那么）

Sub test1()

If [a1] = "" Then

MsgBox "A1单元格没有输入任何内容！" End If

End Sub

if—then—else语句（如果，那么，否则）

Sub test2()

If [a1] = "" Then

MsgBox "A1单元格没有输入任何内容！"

Else

MsgBox "A1单元格已经输入了内容！"

End If

End Sub

if—then—elseif语句（如果，那么，否则如果，那么，否则）

Sub test3()

If [a1] = "" Then

MsgBox "A1单元格没有输入任何内容！"

ElseIf [a1] Mod 2 = 0 Then

MsgBox "A1单元格的数能被2整除！"

ElseIf [a1] Mod 3 = 0 Then

MsgBox "A1单元格的数能被3整除！"

ElseIf [a1] Mod 5 = 0 Then

MsgBox "A1单元格的数能被5整除！"

Else

MsgBox "A1单元格的数不能被2、3、5其中之一整除！"

End If

End Sub

程序流程控制——Select Case语句

Sub test()

If [a1].Value = "" Then

MsgBox "A1单元格没有输入数字。"

Exit Sub ' 退出程序

End If

Select Case [a1].Value

Case 0 To 29

MsgBox "差"

Case 30 To 59

MsgBox "不及格"

Case 60 To 79

MsgBox "及格"

Case 80 To 89

MsgBox "良好"

Case Else

MsgBox "优秀"

End Select

End Sub

Sub Test()

If [a1].Value = "" Then

MsgBox "A1单元格没有输入数字。"

Exit Sub ' 退出程序

End If

Select Case [a1].Value

Case Is < 30

MsgBox "差"

Case Is < 60

MsgBox "不及格"

Case Is < 80

MsgBox "及格"

Case Is < 90

MsgBox "良好"

Case Else

MsgBox "优秀"

End Select

End Sub

程序流程控制——For—Next 循环语句

Sub mysum()

Dim Lsum As Long, i As Long

For i = 1 To 1000

Lsum = Lsum + i

Next

MsgBox "1到1000的自然数和为：" & Lsum

End Sub

Sub 求1到10000之间偶数和()

Dim I&, J&

For I = 0 To 10000 Step 2

J = J + I

Next

MsgBox "1到10000之间偶数和为" & J

End Sub

Sub 求1到10000之间偶数和2()

Dim I&, J&

For I = 10000 To 1 Step -2

J = J + I

Next

MsgBox "1到10000之间偶数和为" & J

End Sub

Sub 求1到10000之间奇数和()

Dim I&, J&

For I = 1 To 10000 Step 2

J = J + I

Next

MsgBox "1到10000之间奇数和为" & J

End Sub

Sub 求1到10000之间奇数和2()

Dim I&, J&

For I = 9999To 1 Step -2'此句于2009年8月18日纠正

J = J + I

Next

MsgBox "1到10000之间奇数和为" & J

End Sub

Sub 求1到10000之间能被5整除的数之和()

Dim I&, J&

For I = 0 To 10000 Step 5

J = J + I

Next

MsgBox "1到10000之间能被5整除的数之和为" & J

End Sub

Sub 求1到10000之间能被5整除的数之和2()

Dim I&, J&

For I = 10000 To 1 Step -5

J = J + I

Next

MsgBox "1到10000之间能被5整除的数之和为" & J

End Sub

程序流程控制——For—Each 循环语句

Sub shtname()

Dim i As Integer, sht As Worksheet

i = 1

For Each sht In Worksheets

Cells(i, 1) =

i = i + 1 '让写入名称的单元格下移一行

Next

End Sub

程序流程控制——Do While语句

Sub mysum()

Dim Lsum As Long, i As Long

i = 1

Do While i <= 1000

Lsum = Lsum + i

i = i + 1

Loop

MsgBox "1到1000的自然数和为：" & Lsum

End Sub

程序流程控制——Do Until 语句

Sub mysum()

Dim Lsum As Long, i As Long

i = 1

Do

Lsum = Lsum + i

i = i + 1

Loop Until i > 1000

MsgBox "1到1000的自然数和为：" & Lsum

End Sub

程序流程控制——Go to 语句

Sub mysum()

Dim Lsum As Long, i As Long

i = 1

x: '为go to 语句设置的标签，必须以英文状态下的冒号结尾

Lsum = Lsum + i

i = i + 1

If i <= 1000 Then GoTo x '如果i<=1000,则程序跳到标签X处

MsgBox "1到1000的自然数和为：" & Lsum

End Sub

显示窗体

显示窗体的语句：

（1）模式窗体的显示代码：

窗体名称.Show vbModal

也可以写成：窗体名称.Show 1

（2）无模式窗体的显示代码：

窗体名称.Show vbModeless

也可以写成：窗体名称.Show 0古今名言

敏而好学，不耻下问——孔子

业精于勤，荒于嬉；行成于思，毁于随——韩愈

兴于《诗》，立于礼，成于乐——孔子

己所不欲，勿施于人——孔子

读书破万卷，下笔如有神——杜甫

读书有三到，谓心到，眼到，口到——朱熹

立身以立学为先，立学以读书为本——欧阳修

读万卷书，行万里路——刘彝

黑发不知勤学早，白首方悔读书迟——颜真卿

书卷多情似故人，晨昏忧乐每相亲——于谦

书犹药也，善读之可以医愚——刘向

莫等闲，白了少年头，空悲切——岳飞

发奋识遍天下字，立志读尽人间书——苏轼

鸟欲高飞先振翅，人求上进先读书——李苦禅

立志宜思真品格，读书须尽苦功夫——阮元

非淡泊无以明志，非宁静无以致远——诸葛亮

熟读唐诗三百首，不会作诗也会吟——孙洙《唐诗三百首序》

书到用时方恨少，事非经过不知难——陆游

问渠那得清如许，为有源头活水来——朱熹

旧书不厌百回读，熟读精思子自知——苏轼

书痴者文必工，艺痴者技必良——蒲松龄

声明

访问者可将本资料提供的内容用于个人学习、研究或欣赏，以及其他非商业性或非盈利性用途，但同时应遵守著作权法及其他相关法律的规定，不得侵犯本文档及相关权利人的合法权利。谢谢合作！