一：宏编程
1 用宏编程写“hello world ”程序
Sub HelloWorld()
MsgBox ("hello world !")
End Sub
2 简单的用户交互
Sub Hello()
Dim X
X=InputBox("请输入您的姓名：")
MsgBox("欢迎"& X &"来到宏编程的世界！")
End Sub
可以定制title和对话框
Sub Hello
Dim X
Dim Y
x=InputBox("您的姓名是","姓名输入框（这是title）","请在这输入姓名（这是站位字符串）")
Y=MsgBOx("欢迎"& X &"我的朋友",0,"这是欢迎对话框（这是title）")
End Sub
使用选择结构if else
Sub Hello2()
Dim X
Dim Y
X = InputBox("请输入您的姓名:", "姓名输入框", "andy")
If X <> "" Then
MsgBox ("你好" & X & "我的朋友")
Else
MsgBox ("你还没有输入姓名")
End If
End Sub
3:在宏编程中使用循环、选择结构，以及生成随机数，数据类型转换
Sub Hello3()
Dim a, b, c, d '申明了四个变量，变量间用英文逗号分开，与前面实例二申明变量的写法不同，结果相同。
a = 0 '这个变量用于计算您猜了多少次。
Randomize '准备生成一个随机的数字，先初始化随机数生成器。
b = Int(100 * Rnd) '生成一个百以内的随机数，“Rnd”就是“随机数生成函数”。
Do '开始循环
a = a + 1 '您猜的次数增添一次。当再次循环到这儿时，次数会继续往上加。
c = InputBox("请输入您所猜的数") '将取得的值赋予变量“c”，“c”是字符串！
d = CInt(c) '将变量“c”转化为整数，再将值赋给“d”。
If b < d Then '进行比较，如果猜大了。
MsgBox ("您猜的数大了") '显示比较的结果。
ElseIf b > d Then '进行比较，如果猜小了。
MsgBox ("您猜的数小了") '显示比较的结果。
Else: b = d '进行比较，如果猜对了。
MsgBox ("哈哈,您猜对了!") '显示比较的结果。
Exit Do '既然已经猜对了，就跳出循环。
End If '结束比较。
Loop '回到前面的Do,继续循环。
MsgBox ("您猜了" & a & "次!") '弹出消息框，并使用了字符串连接。
End Sub '结束程序。
4 利用宏选中word中的所有文档
Sub SelectAllTables()
Dim mytable As Table
Application.ScreenUpdating = False
For Each mytable In ActiveDocument.Tables
mytable.Range.Editors.Add wdEditorEveryone
Next
ActiveDocument.SelectAllEditableRanges (wdEditorEveryone)
ActiveDocument.DeleteAllEditableRanges (wdEditorEveryone)
Application.ScreenUpdating = True
End Sub
5 利用宏选中word中的所有表格
Sub AutoAdapt()
Application.Browser.Target = wdBrowseTable
For i = 1 To ActiveDocument.Tables.Count
With ActiveDocument.Tables(i)
.AutoFitBehavior (wdAutoFitWindow) '根据窗口调整内容
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter '水平居中
.Range.ParagraphFormat.Alignment = wdCellAlignVerticalCenter '垂直居中
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleInset '加水平线
End With
Next i
End Sub
二:Word VBA详解
1 集合、对象、属性、方法
什么是集合
集合就是一系列相同属性元素的称谓，集合里面的每一个元素就是对象
'常用集合
'文档集合 documents
'段落集合Paragraphs
'表格集合tables
什么是对象
常用对象
'document 对象 :activedocument,thisdocument,documents("文档名")...
'Range 对象，该对象代表指定对象中包含的文档部分。
'Selection 对象，该对象代表一个选定的范围或插入点
'Words (Index) Range (单词：所选内容、范围或文档中的单词的集合，返回的是Range对象)
'Characters (Index) Range (字符：选定内容、区域或文档中的字符的集合，返回的是Range对象)
'Sentences (Index) Range (句子：所选内容、范围或文档中的所有句子。返回的是Range对象)
'Paragraphs (Index) Paragraph(段落：返回的是Paragraph对)
'Sections (Index) Section （节：所选内容、范围或文档中的 Section 对象的集合。）
activedocument:活动文档，就是当前编辑的文档
thisdocument:代码运行所在的文档
什么是属性？
Sub 属性()
'MsgBox ActiveDocument.FullName '属性的读取
'Selection.Words(9).Bold = True '属性的修改
End Sub
ActiveDocument.FullName就是获取活动文档的全路径名称
Selection.words(9).Bold = True 就是在当前鼠标拉取选中的数据中的第九个加粗，Bold就是加粗的意思
什么是方法？
Sub 方法()
'Selection.Delete ’选中删除
'Selection.Cut '选中剪切
'Selection.Paste '选中粘贴
End Sub
2 变量，常量，数据类型
常量
常量， 就是在某一过程中数值不变的量。如每星期的天数 ，水在一标准大气压下的沸点
在VBA中使用关键字Const给常量赋值
SUb A()
Const pi=3.1415926
MsgBox pi
'如果强行的给常量赋值的话office就会报错
End Sub
本地窗口
点击视图-->本地窗口
想要查看变量的状态就要在调试状态中，点击当前方法，按F8调试，就可以在本地窗口中查看相关信息
本地窗口就是可以实时的查看本地定义的变量和常量的状态和值
变量
变量，就是变化的量，包含数字，字母，下划线，开头不能为数字
命名的存储位置，包含在程序执行阶段修改的数据。每一变量都有变量名，在其范围内可唯一识别。可以指定数据类型，也可以不这样做。变量名必须以字母字符开头，在同一范围内必须是唯一的，不能超过 255 个字符，而且中间不能包含句点或类型声明字符。
在程序中遵循先定义，再使用的原则
Sub demo()
Dim x
Dim y
Dim a,b,c '当然可以一个一个的定义，还可以使用逗号分隔进行变量的定义
End Sub
在前面加Const是定义常量，加Dim是定义变量，如果直接写像如下代码
Sub demo1()
name="andy"
End Sub
这样的话就是隐式变量，也可以使用，但是会有概念问题，最好是先定义，再使用
数据类型
常见数据类型
'变量的特性，用来决定可保存何种数据。数据类型包括 ：
'Byte 字节
'Boolean 布尔型
'Integer（%） 整数型
'Long（&） 长整型
'Currency（@）货币型
'Single（!）单精度浮点型
'Double（#）双精度浮点型
'Date 日期类型
'String（$）文本型
'Object 对象
'Variant ( 默认 ) 不定的数据类型
后面的符号就是数据类型的简写
Dim age% 就是定义一个变量，数据类型是整数型
Sub test3()
Dim f As Integer
Dim n%
MsgBox f
End Sub
我们在定义一个量的时候，as 数据类型，可以增加成员提示，方便我们后面写代码
在我们框选一个数据，按F1就可以查看帮助
我们在定义变量的时候，不声明变量也可以运行程序，如何强制声明数据类型呢
点击工具-->选项-->勾选要求声明变量
在我们的编辑器的代码第一行会出现
Option Explicit
3 分支语句
IF分支语句
If分支语句单行写法
'IF分支语句（单行写法）
Sub iftest1() 'if ...then...
If 99 >= 80 Then MsgBox "恭喜，你合格了": MsgBox "你是优秀的"
End Sub
IF分支语句（块写法1）
Sub iftest2()
If 99 >= 80 Then
MsgBox "恭喜你，合格了！"
MsgBox "您是优秀的"
End If
End Sub
IF分支语句（块写法2）
'IF分支语句（块写法）
Sub iftest3()
If 78 >= 80 Then '那么
MsgBox "你合格了"
Else '否则
MsgBox "你并没有合格"
End If
End Sub
IF分支语句（多条件写法）
'IF分支语句（多条件写法）
Sub test3()
Dim o As Byte
o = InputBox("请输入年龄！")
If o >= 60 Then
MsgBox "老年"
ElseIf o >= 40 Then
MsgBox "中年"
ElseIf o >= 18 Then
MsgBox "青年"
ElseIf o >= 6 Then
MsgBox "少年"
Else
MsgBox "童年"
End If
End Sub
SelectCase分支语句
'selection普通写法
Sub s1()
Dim f%
f = InputBox("请输入分数")
Select Case f
Case 0 To 59
MsgBox "差"
Case 60 To 79
MsgBox "中"
Case 80 To 89
MsgBox "良"
Case 90 To 100
MsgBox "优"
Case Else
MsgBox "你输入的分数不正确"
End Select
End Sub
Sub test1()
Dim x As Integer
x = InputBox("请输分数！")
Select Case x
Case Is >= 90
MsgBox "优"
Case Is >= 80
MsgBox "良"
Case Is >= 60
MsgBox "中"
Case Else
MsgBox "差"
End Select
End Sub
4 循环语句
for循环
在for循环中，指定一个变量，然后用to左右链接范围，step表示步长，-数表示倒着循环
Sub test()
for i=1 To 10 step 2
MsgBox(i)
Next i
End Sub
将选中文字随机设置颜色
Sub SetColor()
Dim i%,cht as Range
For i=1 To Selection.Characters.COunt
Selection.Characters(i).Font.Fill.ForeColor.RGB = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Next i
End Sub
For Each循环集合或者数组
eg：为框选数据设置渐变色
Sub SetColor() '设置所选字的颜色
Dim c As Range, n% ' 定义一个c和数字n，n的初始值默认为0
For Each c In Selection.Characters
n = n + 5
'这个地方的c就是一个集合中的元素，表示框选中的一个字符，包括符号
c.Font.Fill.ForeColor.RGB = RGB(n, n, 0)
Next c
End Sub
效果如下
注：在for循环中，想要停止循环可以采用如下的代码实现功能
if a==10 '条件
Exit FOr '满足条件停止循环
无限循环 Do ..Loop
Sub setColor1() '使用Do ... loop实现改变所选数据颜色
Dim n%, c As Range
Do
n = n + 1
Selection.Characters(n).Font.Fill.ForeColor.RGB = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Loop Until n = Selection.Characters.Count
' Until 表示直到什么条件推出循环
' while 表示在什么条件下执行循环，类似于js的do while
End Sub
5 运算符详解
1 数字运算符
'+、-、*、\、/、mod
Sub Operation() ' 运算符重载
MsgBox (5 / 2) ' / 表示除法，结果是浮点数
MsgBox (5 \ 2) ' \ 表示取整，类似于Python的//
MsgBox (5 Mod 2) 'mod 表示取余，类似于Python的%
MsgBox "o" Like "*"
End Sub
使用mod的例子
Sub SelectFontStyles()
Dim icount%
For icount = 1 To Selection.Characters.Count
Select Case icount Mod 3
Case 0
Selection.Characters(icount).Font.Fill.ForeColor.RGB = RGB(255, 0, 0)
Case 1
Selection.Characters(icount).Font.Fill.ForeColor.RGB = RGB(0, 255, 0)
Case 2
Selection.Characters(icount).Font.Fill.ForeColor.RGB = RGB(0, 0, 255)
End Select
Next icount
End Sub
2 比较运算符
'=、>、>=、<、<=、<>、like
'着重来看一下like
Sub Compare()
result= "andy" Like "a*y" ' 结果为True
MsgBox(result)
End Sub
' "?" 表示匹配任意一个字符
' "*" 贪婪匹配，表示匹配0或多个字符
' "#" 表示匹配任意一个0-9的数字
' [ charlist ] charlist 内的任意单个字符。
' [ !charlist ] charlist 外的任意单个字符。
eg:
Dim MyCheck
MyCheck = "aBBBa" Like "a*a" ' Returns True.
MyCheck = "F" Like "[A-Z]" ' Returns True.
MyCheck = "F" Like "[!A-Z]" ' Returns False.
MyCheck = "a2a" Like "a#a" ' Returns True.
MyCheck = "aM5b" Like "a [L-P]#[!c-e]" ' Returns True.
MyCheck = "BAT123khg" Like "B?T*" ' Returns True.
MyCheck = "CAT123khg" Like "B?T*" ' Returns False.
MyCheck = "ab" Like "a*b" ' Returns True.
MyCheck = "a*b" Like "a [*]b" ' Returns False.
MyCheck = "axxxxxb" Like "a [*]b" ' Returns False.
MyCheck = "a [xyz" Like "a [[]*" ' Returns True.
MyCheck = "a [xyz" Like "a [*" ' Throws Error 93 (invalid pattern string).
注：参与数字运算的结果是数字，参与比较运算的结果是布尔值，True or False
3 & and or
& 连接运算符
and or 逻辑运算符
看一个收集一段文本里面英文字母的案例
Sub CollectLetter()
Dim n As Range, s$
For Each n In Selection.Characters
'If n.Text >= "A" And n.Text <= "z" Then
If n.Text Like "[A-Za-a]" Then
s = s & n.Text & " "
End If
Next n
MsgBox (s)
End Sub
将一段文本中的字母，数字着色
Sub Color()
Dim n As Range
For Each n In Selection.Characters
If n.Text Like "[A-Za-z0-9%]" Then
n.Font.Fill.ForeColor.RGB = RGB(0, 255, 0)
End If
Next n
End Sub
运行的结果展示
6 Word文档的常规操作(新建、打开、保存、关闭)
把对象当做参数赋值给一个变量的时候，变量前面加Set
文档的创建和保存
Sub Operation1() ' 保存在当前活动文档目录下
Dim doc As Document
Set doc = Documents.Add '创建
doc.SaveAs ThisDocument.Path & "\111.docx" '保存
'doc.SaveAs "E:\VBA\123.docx）" '保存在指定路径下
doc.Close ' 关闭
End Sub
Sub Operation2() '使用activedocument操作
Documents.Add.SaveAs ThisDocument.Path & "\123.docx"
ActiveDocument.Close
End Sub
文档的打开和保存
Sub Demo()
Dim doc As Document
Set doc = Documents.open(ThisDocument.Path & "\123.docx")
Selection.TypeText Now '把当前时间写入到docx文档中
doc.save ' 保存'
doc.Close -1 '关闭 后面接 0表是关闭不保存，-1表示关闭前保存 -2表示弹出保存提示框
End Sub
上面的代码实现了打开一个docx文档，然后保存当前时间到光标的位置
文档名的获取
ActiveDocument ' 活动文档'
ThisDocument '当前文档'
ThisDocument.Path '当前文档路径'
循环获取当前路径下的文档名
'for循环Count
Sub GetDocumentName()
Dim i%
For i = 1 To Documents.Count
MsgBox Documents(i).Name
Next i
End Sub
'For Each直接循环文档集合
Sub GetDocumentName2()
Dim doc As Document
For Each doc In Documents
'MsgBox(doc.Name)
MsgBox (Documents(doc.Name).Name)
Next doc
End Sub
7 Selection常规操作
Sub test()
'Selection
'代表窗口或窗格中的当前所选内容。所选内容代表文档中选定（或突出显示）的区域，如果文档中没有选定任何内容，则代表插入点。
'每个文档窗格只能有一个 Selection 对象，并且在整个应用程序中只能有一个活动的 Selection 对象。
'---------插入点的基本操作-------------
'Selection.TypeText Now '插入点写入当前日期时间
'Selection.TypeParagraph '插入点写入段落标记,与Selection.TypeText Chr(13)等同
'Selection.TypeBackspace '插入写入退格标记
'---------选择区域的基本操作------------
Selection.Copy '复制
Selection.Cut '剪切
Selection.Paste '粘贴
Selection.Delete '清除
End Sub
将当前文档中框选的文本复制到一个新建的文档中
Sub Demo1()
Selection.Copy
MsgBox (ThisDocument.Path & "\" & Format(Now, "yyyy-m-d(hh:nn:ss)") & ".docx")
Documents.Add.SaveAs ThisDocument.Path & "\" & Format(Now, "yyyy年mm月dd日 hh时nn分ss秒") & ".docx" '
Selection.Paste
ActiveDocument.Close -1
End Sub
8 Range的方法和属性应用
Range,制定段落中包含的文档部分，文档对象.Range(Start,End)，他的两个参数忽略之后就是光标向右一一个字符
1 作为document的方法
MsgBox ActiveDocument.Range(5) '表示当前文档第五个字符之后所有的字符
2 作为Selection的方法
Selection.Range.Bold=True '表示将选择的文本的字体加粗
3 作为段落Paragraphs的方法
Selection.Pargraphs(1).Range.Bold = True '表示所选文本的第一段的所有文本的字体加粗
4 将所选的一段文本隔行加粗
Sub Demo()
Dim i%
For i = 1 To Selection.Paragraphs.Count Step 2
Selection.Paragraphs(i).Range.bold=True
Next i
End Sub
9 光标移动Move和Expand
Move就是控制光标的移动，按照字词句段这样的操作
Expand就是扩展，意思就是光标所在地方根据后面参数进行补全选择，如果是2 ，就是选择这个句子，如果是5就是选择这一行
Sub Demo()
Selection.Move Start,End
' 后面的第一个参数就是上面图片中的枚举类型，可以直接写名称，也可以写后面的数字
Selection.Move 1 '表示光标向右移动一个字符
End Sub
1,2,3,4,5 分别表示字，词，句，段，行
案例1 按照句子写序号
Sub SetSentence()
Dim i%, s%
s = InputBox("请输入您要标注的句子数量：")
For i = 1 To s
Selection.Move wdSentence, 1 ' 在光标按照句子移动
If i = 1 Then
Selection.Move 3, -1 ' 光标按照句子移动到前一个句子，因为step为-1
End If
Selection.TypeText i & "、" ' 写入数据
Next i
End Sub
案例二 给选定的行着色
Sub Demo()
Dim i%, k%
k = InputBox("请输入要着色多少刚")
For i = 1 To k
Selection.Move 1, 1
Selection.Expand 5
Selection.Font.Fill.ForeColor.RGB = RGB(100 * (i Mod 2 + 1), 50 * (i Mod 2), 0)
Next i
End Sub
10光标移动Collaps和Infomation
Collpase
指定某范围或所选内容的折叠方向
Collapse
Selection.Collapse
Range.Collapse
'wdCollapseEnd 0 将该范围折叠到结束点。 'wdCollapseStart 1 将该范围折叠到起始点。
0就是光标定位到末尾，1就是光标定位到开始位置
指定每一段的字数
Sub Demo()
Dim x As Paragraph
For Each x In ThisDocument.Paragraphs ' 循环段落'
x.Range.Select '选择这一段'
Selection.Collapse 0 ' 光标定位到这一段的末尾'
Selection.Move 1, -1 '光标向左一个字符，即一段的末尾位置，除了制表符'
'Selection.TypeText "<" & p.Range.Characters.Count & "字" & ">"
Selection.TypeText "共<" & x.Range.Characters.Count - 1 & ">字"
Next x
End Sub
循环段落，然后操作段落的属性
Sub demo2()
Dim p As Paragraph, rng As Range
For Each p In ThisDocument.Paragraphs ' 循环段落'
Set rng = p.Range '使用Range获取段落的属性'
rng.Collapse 0 ' 光标定位到结尾'
rng.Move 1, -1 ' 光标定位到换行符之前'
rng.Text = "(" & p.Range.Characters.Count & "个字)"
Next
End Sub
Infomation
指定返回的涉及指定所选内容或区域的信息的类型
'Information
'Selection.Information
'Range.Information
给一段文本上底色
Sub add()
Dim f%,e%,i%
f=Selection.Information(wdFirstCharacterLineNumber) '当前光标所在行数'
Selection.Collapse 0 '光标定位到段落末尾'
e = Selection.Information(wdFirstCharacterLineNumber) - 1 ' 当前光标所在行数'
For i = f To e
Selection.Move wdLine, -1
Selection.Expand wdLine
If i Mod 2 Then
Selection.Font.Shading.BackgroundPatternColor = RGB(255, 255, 200)
Else
Selection.Font.Shading.BackgroundPatternColor = RGB(180, 255, 230)
End If
Selection.Move wdLine, -1
Next
End Sub
infomation信息说明
'名称 值 说明
'wdActiveEndAdjustedPageNumber 1 返回页码，在该页中包含指定的所选内容或区域的活动结尾。如果设置一个起始页码或进行其他手动调整，则返回经调整的页码（与 wdActiveEndPageNumber 不同）。
'wdActiveEndPageNumber 3 返回页码，在该页中包含指定的所选内容或区域的活动结尾。从文档开头计数。忽略任何对页码的手动调整（与 wdActiveEndAdjustedPageNumber 不同）。
'wdActiveEndSectionNumber 2 返回节号，在该节中包含了指定的所选内容或区域的活动结尾。
'wdAtEndOfRowMarker 31 如果指定的所选内容或区域位于表格的行结尾标记处，则该参数返回 True。
'wdCapsLock 21 如果 Caps Lock 有效，则该参数返回 True。
'wdEndOfRangeColumnNumber 17 返回表格列号，在该表格列中包含指定的所选内容或区域的结尾。
'wdEndOfRangeRowNumber 14 返回表格行号，在该表格行中包含指定的所选内容或区域的结尾。
'wdFirstCharacterColumnNumber 9 返回指定的所选内容或区域中第一个字符的位置。如果所选内容或区域是折叠的，则返回紧靠所选内容或区域右侧的字符编号（该编号与状态栏中“列”后面的字符列数相同）。
'wdFirstCharacterLineNumber 10 返回指定的所选内容或区域中第一个字符的位置。如果所选内容或区域是折叠的，则返回紧靠所选内容或区域右侧的字符编号（该编号与状态栏中“行”后面的字符行数相同）。
'wdFrameIsSelected 11 如果所选内容或区域是一个完整的图文框或文本框，则该参数返回 True。
'wdHeaderFooterType 33 返回一个值，该值指示包含了指定所选内容或区域的页眉或页脚的类型。有关其他信息，请参阅“注解”部分中的表。
'wdHorizontalPositionRelativeToPage 5 返回指定的所选内容或区域的水平位置。该位置是所选内容或区域的左边缘与页面的左边缘之间的距离，以磅为单位（1 磅 = 20 缇，72 磅 = 1 英寸）。如果所选内容或区域未显示在屏幕上，则该参数返回 -1。
'wdHorizontalPositionRelativeToTextBoundary 7 返回指定所选内容或区域相对于周围最近的正文边界左边缘的水平位置，以磅为单位（1 磅 = 20 缇，72 磅 = 1 英寸）。如果所选内容或区域未显示在屏幕上，则该参数返回 -1。
'wdInClipboard 38 有关该常量的信息，请参阅包含在 Microsoft Office Macintosh Edition 中的语言参考帮助。
'wdInCommentPane 26 如果指定的所选内容或区域位于批注窗格，则该参数返回 True。
'wdInEndnote 36 如果指定的所选内容或区域位于页面视图的尾注区内，或者位于普通视图的尾注窗格中，则该参数返回 True。
'wdInFootnote 35 如果指定的所选内容或区域位于页面视图的脚注区内，或者位于普通视图的脚注窗格中，则该参数返回 True。
'wdInFootnoteEndnotePane 25 如果指定的所选内容或区域位于普通视图的脚注或尾注窗格中，或页面视图的脚注或尾注区内，则该参数返回 True。有关详细信息，请参阅前面关于 wdInFootnote 和 wdInEndnote 的说明。
'wdInHeaderFooter 28 如果指定的所选内容或区域位于页眉或页脚窗格中，或者位于页面视图的页眉或页脚中，则该参数返回 True。
'wdInMasterDocument 34 如果所选内容或区域位于主控文档（即至少包含一个子文档的文档）中，则该参数返回 True。
'wdInWordMail 37 如果指定的所选内容或区域位于页眉或页脚窗格中，或者位于页面视图的页眉或页脚中，则该参数返回 True。
'wdMaximumNumberOfColumns 18 返回所选内容或区域中任何行的最大表格列数。
'wdMaximumNumberOfRows 15 返回指定的所选内容或区域中表格的最大行数。
'wdNumberOfPagesInDocument 4 返回与所选内容或区域相关联的文档的页数。
'wdNumLock 22 如果 Num Lock 有效，则该参数返回 True。
'wdOverType 23 如果启用改写模式，则该参数返回 True。可使用 Overtype 属性改变改写模式的状态。
'wdReferenceOfType 32 返回一个值，该值表明所选内容相对于脚注、尾注或批注引用的位置，如“注解”部分中的表所示。
'wdRevisionMarking 24 如果打开修订功能，则该参数返回 True。
'wdSelectionMode 20 返回一个值，该值表明当前的选定模式，如下表所示。
'wdStartOfRangeColumnNumber 16 返回表格列号，在该表格列中包含所选内容或区域的起点。
'wdStartOfRangeRowNumber 13 返回表格行号，在该表格行中包含所选内容或区域的起点。
'wdVerticalPositionRelativeToPage 6 返回所选内容或区域的垂直位置，即所选内容的上边缘与页面的上边缘之间的距离，以磅为单位（1 磅 = 20 缇，72 磅 = 1 英寸）。如果所选内容未显示在文档窗口中，则该参数返回 -1。
'wdVerticalPositionRelativeToTextBoundary 8 返回所选内容或区域相对于周围最近的正文边界的上边缘的垂直位置，以磅为单位（1 磅 = 20 缇，72 磅 = 1 英寸）。该参数可用于在图文框或表格中确定插入点位置。如果所选内容未显示在屏幕中，则该参数返回 -1。
'wdWithInTable 12 如果所选内容位于表格中，则该参数返回 True。
'wdZoomPercentage 19 返回由
11 光标移动之上下左右
我们的光标可以上下左右的移动，不光可以移动，还可以选择文本
'Selection.MoveUp '上
'Selection.MoveDown '下
'Selection.MoveRight '右
'Selection.MoveLeft '左
按照字数着色
框选一段文本，然后每隔几个字符着色，使用Selection.MoveRight
Sub Demo()
Dim icount%,n%,i% '定义三个数字类型的变量'
n=InputBox("请输入要着色的字数") '输入要着色的字数'
icount=Selection.Characters.Count '收集选择的文本的个数'
Selection.Collapse 1 ' 光标定位到开始位置'
For i=1 To icount/n '循环的次数为文本数/着色的字数'
Selection.MoveRight 1,n,wdExtend '向右移动n位，填充'
Selection.Font.Shading.BackgroundPatternColor = RGB(255 * (i Mod n), 100, 255) '设置 背景色'
Selection.Collapse 0 '光标定位到末尾'
Next i
End Sub
给一段文本隔行染色
1 自上而下
Sub demo()
Dim n%,i%
Dim rng As Range, f%, e%, r% '参数的定义'
r = InputBox("请输入隔行着色的行数")
'-------------结束点---------------
Set rng = Selection.Range '当前框选文本的集合'
rng.Collapse 0 '光标定位到集合末尾'
e = rng.Information(wdFirstCharacterLineNumber) '获取光标当前所在文本的行数
'-------------起始点---------------
Set rng = Selection.Range '当前框选文本的集合'
rng.Collapse 1 '光标定位到集合头部'
f = rng.Information(wdFirstCharacterLineNumber)'获取光标当前所在文本的行数
rng.Select '选择'
For i = f / r To e / r - 1
n = n + 1
Selection.MoveDown wdLine, r, wdExtend '光标向下移动r行，并框选'
Selection.Expand wdLine '填充当前行'
Selection.Font.Shading.BackgroundPatternColor = RGB(100 * (n Mod r), 100, 200)
Selection.Collapse 1 '光标设置在当前选择的末尾
Selection.MoveDown wdLine, r ' 光标向下移动一行，不框选
Next
End Sub
2 自下而上
'模块，自下而上
Sub Demo()
Dim i%, n%, rng As Range, f%, e%
n = InputBox("请输入连续行数")
Set rng = Selection.Range '选择的文本这个集合
f = rng.Information(wdFirstCharacterColumnNumber) '获取当前光标行数
rng.Collapse 0 '光标移动到末尾
e = rng.Information(wdFirstCharacterColumnNumber) ' 获取当前光标位置
rng.Select
For i = f / 2 To e / 2 - 1
Selection.MoveUp wdLine, n, wdExtend ' 光标上移
Selection.Expand wdLine ' 扩展
Selection.Font.Shading.BackgroundPatternColor = RGB(255, 20 * n, 100)
Selection.Collapse 1 '光标移动到头部
Next i
End Sub
12 光标移动之拆分页到单个文档
Sub test()
'Selection.HomeKey wdStory, wdExtend '光标所在位置到文档的开始位置'
'Selection.EndKey wdStory, wdExtend '光标所位置到文档的结束位置'
'a = Selection.Start '选择内容的开始位置'
'b = Selection.End '选择内容的结束位置'
'c = ActiveDocument.Paragraphs(3).Range.Start '段落的开始位置'
'd = ActiveDocument.Paragraphs(3).Range.End '段落的结尾位置'
a = Selection.GoTo.Start '光标定位到下一页'
End Sub
按照页数拆分文档
Sub demo222()
Dim n%, a%, b%, na$ ' 定义参数
Selection.HomeKey wdStory '光标定位到文档开头位置
'ThisDocument.BuiltInDocumentProperties(14)获取当前页数
For n = 1 To ThisDocument.BuiltInDocumentProperties(14) - 1
Selection.GoTo ' 光标定位到下一页的开头位置
a = Selection.GoTo(wdGoToPage, wdGoToPrevious, 1).Start '获取上一页开头位置的索引
b = Selection.GoTo.Start ' 又重新获取到当前页开头的索引
ThisDocument.Range(a, b).Copy '复制中间的数据
Documents.Add '新建一个文档
Selection.Paste '粘贴
ActiveDocument.Range(0, 0).Select '选择文档开头位置
Selection.Expand wdLine '扩展选中
na = Selection.Range.Text '获取选中文本
na = Left(na, Len(na) - 1) '剪切
ActiveDocument.SaveAs2 ThisDocument.Path & "\" & n & "." & na & ".docx" '将文档命名
ActiveDocument.Close '关闭活动文档
Next
End Sub
几种枚举类型参数简介
'WdGoToItem 枚举
'指定要将插入点或所选内容移到其正前方的项目类型
' 名称 值 说明
' wdGoToBookmark -1 书签。
' wdGoToComment 6 批注。
' wdGoToEndnote 5 尾注。
' wdGoToEquation 10 公式。
' wdGoToField 7 域。
' wdGoToFootnote 4 脚注。
' wdGoToGrammaticalError 14 语法错误。
' wdGoToGraphic 8 图形。
' wdGoToHeading 11 标题。
' wdGoToLine 3 一个线段。
' wdGoToObject 9 对象。
' wdGoToPage 1 页。
' wdGoToPercent 12 百分比。
' wdGoToProofreadingError 15 校对错误。
' wdGoToSection 0 一节。
' wdGoToSpellingError 13 拼写错误。
' wdGoToTable 2 一个表格
'WdGoToDirection 枚举
'指定要相对于对象或其自身移动所选内容或插入点的位置
' 名称 值 说明
' wdGoToAbsolute 1 绝对位置。
' wdGoToRelative 2 相对于当前位置的位置。
' wdGoToFirst 1 所指定对象的第一个实例。
' wdGoToLast -1 所指定对象的最后一个实例。
' wdGoToNext 2 所指定对象的下一个实例。
' wdGoToPrevious 3 所指定对象的上一个实例。
'WdBuiltInProperty 枚举
'指定内置文档属性
'wdPropertyLastAuthor 7 上一个作者。
'wdPropertyRevision 8 修订次数。
'wdPropertyAppName 9 应用程序名称。
'wdPropertyTimeLastPrinted 10 上次打印时间。
'wdPropertyTimeCreated 11 创建时间。
'wdPropertyPages 14 页数。
'wdPropertyCharacters 16 字符数。
'wdPropertySecurity 17 安全设置。
'wdPropertyCategory 18 类别。
'wdPropertyFormat 19 不支持。
'wdPropertyManager 20 经理。
'wdPropertyCompany 21 公司。
'wdPropertyBytes 22 字节数。
'wdPropertyLines 23 行数。
'wdPropertyParas 24 段落数。
'wdPropertySlides 25 不支持。
'wdPropertyNotes 26 注释。
'wdPropertyHiddenSlides 27 不支持。
'wdPropertyMMClips 28 不支持。
'wdPropertyHyperlinkBase 29 不支持。
'wdPropertyCharsWSpaces 30 字符数（计空格）。
13 字符的应用（Character）
间隔字符操作
Sub demo1()
Dim n%
MsgBox ActiveDocument.Characters.Count
For n = 1 To ActiveDocument.Characters.Count Step 2 '根据字符数循环，步长为2
ActiveDocument.Characters(n).Font.Fill.ForeColor.RGB = RGB(255, 0, 0) '上色
Next n
End Sub
竖着隔行上色
Sub Demo()
Dim p As Paragraph
Dim n%
For Each p In ActiveDocument.Paragraphs
For n = 1 To p.Range.Characters.Count Step 2
p.Range.Characters(n).Font.Fill.ForeColor.RGB = RGB(0, 255, 0)
Next n
Next p
End Sub
14 词（word）的应用
Sub Demo()
Dim w As Range
For Each w in ActiveDocument.Paragraphs(1).Range.Words '第一段的所有的词
if Len(w.text)>1 Then '如果长度大于1'
Selection.typeText w.Text & " " '打印在文档中，用空格隔开'
End If
Next w
End Sub
15 句（Sentence）的应用
Sentences就是获取对象中的句子
with Selection...End with-->可以将包含的语句中点前面的代码省略，但是在with后一定要写，点不能省略
Sub Demo()
Dim s As Range
For Each s In ActiveDocument.Paragraphs(1).Range.Sentences '获取第一段对象的所有句子并循环'
n = n + 1
With Selection
.TypeText s '写句子'
.Expand wdLine '扩展'
.Font.Fill.ForeColor.RGB = RGB(40 * n, 0, 0) '设置颜色'
.Font.Bold = True '加粗'
.Collapse 0 '光标定位到最后'
'Selection.Move , -1 '向下一动一行'
.TypeParagraph '添加一个回车符号'
End With
Next
End Sub
16 段落的应用
计算一篇文档每段的字数
Sub Demo()
Dim n%, icount%, m%
For n = 1 To ActiveDocument.Paragraphs.Count '获取当前文档的段落数，并循环
m = ActiveDocument.Paragraphs(n).Range.Characters.Count - 1 '获取当前段落的字符数，赋值给m
icount = ActiveDocument.Paragraphs(n).Range.End '获取当前段落最后一个字符的位置
ActiveDocument.Characters(icount) = "（" & m & "个字）" & Chr(13) '写结果到最后字符
Next n
End Sub
17 Word Vba常用函数1 （空白字符应用）
vba.Asc 将普通字符编码成ascii码表
VBA.chr() 将ascii解码成普通字符
Sub test()
'制表符 Chr(9)
'换行符 Chr(11)
'换页符 Chr(12)
'回车符 Chr(13)
Selection.TypeText Chr(12)
End Sub
完成一个乘法口诀表
Sub multiplication_tables()
Dim n%, m%
For m = 1 To 9
For n = 1 To 9
If n <= m Then
Selection.TypeText m & "x" & n & "=" & m * n & Chr(9)
Else
Selection.TypeText Chr(11)
Exit For
End If
Next n
Next m
End Sub
18 Word Vba常用函数2 （文本函数应用）
'--------常用文本函数-----------
'左: Left 从指定字符串左侧开始选取指定长度的字符串（'old_str',长度）
'中: Mid 从指定字符串中选取指定长度的字符串（'old_str',开始位置,长度）
'右: Right 从指定字符串右侧开始选取指定长度的字符串（'old_str',长度）
'长度：Len 字符串的长度
'查找：Instr 从字符串中搜索字符串
'查找替换：Replace
'重复：String
'格式化：Format
1根据日期算星期几
Sub 根据日期计算星期几()
Dim c As Paragraph
For Each c In Selection.Range.Paragraphs
c.Range.Select
Selection.Collapse wdCollapseEnd
Selection.Move 1, -1
Selection.TypeText Chr(9) & Format(c.Range, "aaaa")
Next c
End Sub
2 根据成绩评定星级
Sub xxx()
Dim n As Paragraph, d$ '定义一个循环体和一个字符串
For Each n In Selection.Range.Paragraphs '循环段落
d = Mid(n.Range, InStr(n.Range, " ") + 1, 3) '先查出空格，然后使用mid切分字符串
n.Range.Select '选中
Selection.Collapse 0 '末尾
Selection.Move 1, -1 ' 移动到上一格
Selection.TypeText Chr(9) & String(Int(d / 10 + 1) - 6, "*") '写数据
Next n
End Sub
19 Word Vba常用函数3（数字函数应用）
'abs 绝对值
'int 取整
'IsNumeric '是否是数字
'Val '将字符串数字转为数值型数字
'Round '四舍五入函数
'Rnd '随机函数
'mod 余数运算符
计算word文档中的工资的总和
Sub jisuan_sum()
Dim str$, num%, n As Range
For Each n In ActiveDocument.Paragraphs(1).Range.Words '循环第一段的词
If IsNumeric(n.Text) Then '如果是数字
str = str & n.Text & "+"
num = num + Val(n.Text)
End If
Next n
MsgBox Left(str, Len(str) - 1) & "=" & num
End Sub
挑选出一段文本中的词，并按照固定的列数写入
Sub demo()
Dim w As Range, n%, m%
m = InputBox("请输入列数！")
For Each w In ActiveDocument.Paragraphs(1).Range.Words
If Len(w.Text) > 1 Then
n = n + 1
If n Mod m Then
Selection.TypeText w.Text & String(12 - Len(w.Text) * 2, " ")
Else
Selection.TypeText w.Text & Chr(11)
End If
End If
Next
End Sub
20 Word VBA中的常用函数4（日期时间函数应用）
'Now '当前日期与时间
'Time '当前时间
'Date '当前日期
'Year '提取年份
'Month '提取月份
'Day '提取天数
'DateSerial '合并日期
'DateAdd ' 实现日期的加减
'DateDiff计算两个日期之间的时间间隔
'DatePart 提取日期的举例当前时间的年，月，日
'Hour '时
'Minute'分
'Second'秒
'TimeSerial '合并时间
'timer 代表从午夜到现在经过的秒数，可以用来计算程序运行的时间
Sub test()
a = Timer
c = b
MsgBox Timer - a
Hour('h',Now)
End Sub
Sub demo() '当月倒计时
Dim idate
idate = DateSerial(Year(Now), Month(Now) + 1, 0) - Date
idate = Format(idate, "00")
ActiveDocument.Range(4, 6).Select
Selection.TypeText idate
End Sub
Sub test3() '当天倒计时
Dim b$
b = Format(1 - Time, "hh小时nn分钟ss秒")
ActiveDocument.Range(12, 23).Select
Selection.TypeText b
End Sub
21 Word VBA中的常用函数5（DIR函数应用）
遍历指定文件夹下的实例
获取其他目录中的文件名，写入word文档
Sub w5()
'Dim sr$, n1%, n2%, n3%
sr = Dir(ThisDocument.Path & "\员工图片\*.png")
Do
n1 = InStr(sr, "-") '搜索-的位置'
n2 = Left(sr, n1 - 1) '截取-之前的文本'
n3 = Replace(Mid(sr, n1 + 1, 9), ".png", "") ' 截取-之后的文本，并去掉.png'
Selection.TypeText n2 & Chr(9) & n3 & Chr(11) '写入文档'
sr = Dir
Loop Until sr = "" '直到sr为空的时候'
End Sub
22 Word VBA中的数组技术（word文档中的筛选）
数组就是一系列元素的集合
数组的定义
Sub Demo()
Dim arr() '或'
arr = Array(1,2,3,4)
Next Sub
split和join
Sub Demo()
arr=Array("a","b","c","d")
s1=arr.join('\') ' 使用将数组\结合为字符串'
arr1 = s1.split("\") '将字符串按照某字符分割成数组
Next Sub
文档的删选实例
Sub demo()
Dim p As Paragraph, ar, n%, m%, arr()
For Each p In Selection.Range.Paragraphs
ar = Split(p.Range, Chr(9))
n = ar(2)
If n >= 10000 Then
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = Join(ar, "\")
End If
Next
Selection.Collapse 0
Selection.TypeText "--------------筛选结果----------------" & Chr(13)
For Each ar In arr
Selection.TypeText ar
Next
End Sub
23 Font介绍
Sub test()
'Selection.Font.Italic = False 设置字体为斜体
'Selection.Font.Bold = False ’ 设置字体加粗
'Selection.Font.Underline = 11
'Selection.Font.UnderlineColor = wdColorRose
'Selection.Font.Size = 50
'Selection.Font.ColorIndex = wdBlue
Selection.Font.Fill.ForeColor.RGB = RGB(255, 30, 100) 设置字体填充色
End Sub
设置波浪字
Sub demo()
Dim x%, y%, n&
Do
For x = 8 To 30 Step 2
If n >= ActiveDocument.Characters.Count Then End
n = n + 1
ActiveDocument.Characters(n).Font.Size = x
Next
For y = 28 To 6 Step -2
If n >= ActiveDocument.Characters.Count Then End
n = n + 1
ActiveDocument.Characters(n).Font.Size = y
Next
Loop
End Sub
第二部分
24 windows窗口基础操作
'1.什么是窗口？
'2.窗口与文档的区别
'3.窗口的表示方法
'Windows (n)
'windows("窗口名称")
'ActiveWindow
'4.窗口集合的常用方法与属性
'新建 '排列 '窗口计数
'5.窗口的范围
'当前程序下
'当前文档下
'活动文档下
'指定文档下
'窗口的常用方法
'激活 新建 关闭
' 勇哥的手记
' 新建的窗口内容都是一样的
' 活动文档是谁，就在谁下面创建窗口
' ActiveDocument.Windows.Add = Windows.Add,这两个是一样的
' 指定文档创建窗口 thisdocument.windows.add
Sub pytest()
'MsgBox ThisDocument.Name '当前文档的名字
'MsgBox Windows(1).Caption ' 当前窗口的名字
'Windows.Add '新建窗口
'Windows.Arrange '窗口的排列
MsgBox Windows.Count '当前窗口的数量
Set s = Windows(1).Parent '窗口的父对象,类型是Document
End Sub
Sub testa()
'Windows.Add
'Windows(2).Activate ' 激活一个窗口成为当前窗口
'MsgBox ActiveWindow.Caption
Windows(1).NewWindow '指定窗口新建一个文档
Windows(2).Close ' 关闭指定的一个窗口
End Sub
Sub max_window() ' 窗口最大化
Dim w As Window
For Each w In Windows
Debug.Print (w.Caption) ' 打印窗口的名称
w.WindowState = wdWindowStateMinimize '窗口最大化wdWindowStateMaximize，最小化wdWindowStateMinimize
Next w
'Application.WindowState = wdWindowStateMaximize '所有应用程序都最大化
'Application.WindowState = wdWindowStateMinimize '所有应用程序都最小化
End Sub
25 Windwos窗口下的对象
' Document -Window - Pane - Page -Rectangle '文档-窗口-窗格-页-文本或图形
Rectangle就是一个个的矩形，可以看成一段一段的
隔页操作
Sub test111()
Dim r As Page, n%
For Each r In ActiveWindow.ActivePane.Pages
n = n + 1
If n Mod 2 Then
r.Rectangles(1).Range.Font.Fill.ForeColor.RGB = RGB(255, 1, 255)
End If
Next r
End Sub
隔行操作
Sub test2() '隔行着色
Dim p As Page, l As Line
For Each p In ActiveWindow.ActivePane.Pages
For Each x In p.Rectangles
For Each l In x.Lines
n = n + 1
If n Mod 2 Then
l.Range.Font.ColorIndex = wdDarkBlue
l.Range.Font.Bold = True
End If
Next
Next
Next
End Sub
26 页拆分文档
Sub demo() '拆分到单个文档
Dim pa As Page, sr As String
For Each pa In ThisDocument.ActiveWindow.ActivePane.Pages
pa.Rectangles(1).Range.Copy
sr = pa.Rectangles(1).Range
sr = Replace(sr, Chr(13), "")
a = ThisDocument.Path & "\123\" & sr & ".docx"
MsgBox a
Documents.Add.SaveAs2 ThisDocument.Path & "\123z"
Selection.MoveUp
Selection.Delete
ActiveDocument.Close -1
Next
End Sub
27 自定义文档合并
Sub test()
'Application.FileDialog 属性
'返回一个 FileDialog 对象，该对象代表文件对话框的单个实例。
'msoFileDialogFilePicker 3 允许用户选择一个文件，只能选择，不能打开----------(文件选取器)
'msoFileDialogFolderPicker 4 允许用户选择一个文件夹，选择文件夹-------------（文件夹选取器）
'msoFileDialogOpen 1 允许用户打开一个文件（可以选择打开一个或多个文件）--（打开）
'msoFileDialogSaveAs 2 允许用户保存一个文件（保存文件）---------------------（另存为）
Dim fi As FileDialog
Set fi = Application.FileDialog(4)
fi.AllowMultiSelect = True
fi.Show
For Each f In fi.SelectedItems
MsgBox f
Next
End Sub
Sub 文档合并()
Dim fd As FileDialog, fn, doc As Document, dn$
Documents.Add
Set fd = Application.FileDialog(3)
With fd
.AllowMultiSelect = True
.Show
For Each fn In .SelectedItems
Set doc = Documents.Open(fn)
With doc
.Range.Copy
dn = .Name
.Close
End With
Selection.Paste
Selection.TypeText "-----------" & dn & Chr(13)
Next
End With
End Sub
28 改造word内置合并文档功能
Sub demo()
Dim fo As FileDialog ' 定义一个FileDialog对象
Set fo = Application.FileDialog(4) '打开文件，选择文件夹
fo.Show ' 弹出选择对话框
ChangeFileOpenDirectory fo.SelectedItems(1) '在对话框中选择第一个文件
myname = Dir("*.docx") '获取文件夹中每一个文件的名字
Do
Selection.InsertFile myname, , , True '插入文本
Selection.TypeText "-------------------------------" & Chr(13) '写文本
myname = Dir
Loop Until myname = ""
End Sub
29 消息对话框
Sub TEST()
Dim c
c = MsgBox("是否计算1+1的结果！", 3 + 32 + 512)
Select Case c
Case 6
MsgBox "结果为2"
Case 7
MsgBox "你并不想计算"
Case 2
MsgBox "你真不想计算"
End Select
End Sub
详细内容 选上msgbox+f1
30 Word批量转化为PDF
Sub doc转PDF()
Dim fd As FileDialog, f, n, arr(), fl, m%
n = MsgBox("是否选择要转为PDF的word文档", 4)
If n = 6 Then
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Show
For Each fl In fd.SelectedItems
m = m + 1
ReDim Preserve arr(1 To m)
arr(m) = fl
Next
MsgBox "请选择要放置的位置的文件夹"
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
For Each f In arr
Documents.Open f
ActiveDocument.SaveAs2 fd.SelectedItems(1) & "\" & Split(ActiveDocument.Name, ".")(0), 17
ActiveDocument.Close
Next
Else
MsgBox "你取消了操作！"
End If
Else
MsgBox "你取消了操作！"
End If
End Sub
第三部分
31 表格在VBA中的基本操作
将word中的表格对象拆分到各个新的文档
Sub 拆分表格到文档()
Dim t As Table, newdoc As Document, f As FileDialog, n%
Set f = Application.FileDialog(4) '弹出选择文件夹的框
f.Show
For Each t In ActiveDocument.Tables '循环所有的表格对象
t.Range.Copy '复制
Set newdoc = Documents.Add '新建文档，赋给newdoc
'newdoc.Range.Paste
Selection.Paste '将粘贴板文本粘贴到活动文档，及新建文档
n = n + 1 '自增1
newdoc.SaveAs2 f.SelectedItems(1) & "\" & n & "班.docx" '将活动文档命名
newdoc.Close ' 关闭当前新建文档
Next
End Sub
32 表格中单元格的相关应用
表格的操作
Sub test()
Dim c As Cell, ce
For Each c In ActiveDocument.Tables(1).Range.Cells
MsgBox Split(c.Range.Text, Chr(13))(0) '获取表格中的信息，使用数组将信息过滤
Next
End Sub
制作九九乘法表
Sub demo2()
On Error Resume Next
Dim t As Table, r As Byte, c As Byte, f%
ActiveDocument.Tables(1).Delete
Set t = ActiveDocument.Tables.Add(Selection.Range, 9, 9) '在光标的位置新建一个9行9列的表格对象
t.Style = "网格型" '为表格添加样式
For r = 1 To 9
For c = 1 To 9
If c <= r Then '当第一个数小于第二个数时
t.Cell(r, c).Range = c & "×" & r & "=" & r * c '往表格里写数据
t.Cell(r, c).Shading.BackgroundPatternColor = RGB(100, r * 10, 210) '给表格设置背景色
f = c + 1
Else
t.Cell(r, f).Delete '删除表格
End If
Next c
Next r
End Sub
33 表格中行列的相关操作
Sub test()
With ActiveDocument.Tables(1) ' 获取表格对象
.Rows '行
.Columns '列
.Rows(1).Cells '第一行的所有的单元格
.Rows(2).Cells(3).Column '第二行。第三列所在的列
.Columns(2).Cells.Item(6).Row.Select ' 第二行列所在的单元格被选择
End With
End Sub
根据表格中的信息提取数据到新的文档
Sub demo()
Dim cl As Cell, fd As FileDialog, bm$, fd1 As FileDialog, doc As Document
Set fd1 = Application.FileDialog(msoFileDialogOpen)
fd1.Show
Set doc = Documents.Open(fd1.SelectedItems(1))
bm = InputBox("请输入你要提取的部门")
MsgBox "选择你要保存的位置！"
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.Show
Documents.Add.SaveAs2 fd.SelectedItems(1) & "\" & bm & ".docx"
With doc.Tables(1)
.Rows(1).Range.Copy
Selection.Paste
For Each cl In .Columns(5).Cells
If Split(cl.Range.Text, Chr(13))(0) = bm Then
cl.Row.Range.Copy
Selection.Paste
End If
Next
ActiveDocument.Close -1
End With
End Sub
34 提取文件信息到表格
'添加行
Activedocument.Tables(1).Rows.Add ActiveDocument.Tables(1).Rows(7) ' 在地7行插入行'
ActiveDocument.Tables(1).Rows(7)。Delete '删除行'
ActiveDocument.Tables(1).Columns(1).Delete '删除列'
Sub test() '提取文件信息到表格
Dim fd As FileDialog, pah As String, tb As Table, c As Cell, arr, arr1
Set tb = ActiveDocument.Tables.Add(Selection.Range, 1, 3)
With tb
.Cell(1, 1).Range = "编号": .Cell(1, 2).Range = "姓名": .Cell(1, 3).Range = "文件类型"
.Style = "网格型"
Set fd = Application.FileDialog(4)
fd.Show
pah = Dir(fd.SelectedItems(1) & "\*.*")
Do
.Rows.Last.Select
Selection.InsertRowsBelow 1
arr = Split(pah, "-")
arr1 = Split(arr(1), ".")
With .Rows.Last.Cells
.Item(1).Range = arr(0)
.Item(2).Range = arr1(0)
.Item(3).Range = arr1(1)
End With
pah = Dir
Loop Until pah = ""
End With
End Sub
结果是
35 表格的拆分
Sub 表格拆分()
Dim c As Cell, n%
With ActiveDocument.Tables(1)
For n = 1 To 3
Documents.Add.SaveAs ThisDocument.Path & "\" & n & "班.docx" '新建班别
For Each c In .Columns(1).Cells '循环判断表格中第1列的值
If Left(c, 2) = n & "班" Or Left(c, 2) = "班别" Then '如果等于某班或等于"班别"
c.Row.Range.Copy '则复制该行的数据
Selection.Paste '粘贴到活动文档中（前面刚新建的文档为活动文档）
End If
Next
ActiveDocument.Close -1 '关闭文档
Next
End With
End Sub
36 合并表格
Sub test()
Dim fd As FileDialog, fn, doc As Document, n%
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Show
For Each fn In fd.SelectedItems
n = n + 1
Set doc = Documents.Open(fn)
If n > 1 Then
doc.Tables(1).Rows(1).Delete
End If
doc.Tables(1).Range.Copy
doc.Close 0
Selection.Paste
Next
End Sub
37 合并表格变异
Sub test()
Dim fd As FileDialog, fn, doc As Document, col As Column, c As Cell, n%
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Show
For Each fn In fd.SelectedItems
Set doc = Documents.Open(fn)
Set col = doc.Tables(1).Columns.Add(doc.Tables(1).Columns(1))
For Each c In col.Cells
c.Range = Split(doc.Name, ".")(0)
Next
col.Cells(1).Range = "班级"
n = n + 1
If n > 1 Then
doc.Tables(1).Rows(1).Delete
End If
doc.Tables(1).Range.Copy
doc.Close 0
Selection.Paste
Next
End Sub
37 合并表格和图片
Sub test()
Dim doc As Document, rs%, ndoc As Document, tb As Table
Dim t As Table, c As Cell, ts As Row, n%
Set doc = Documents.Open(ThisDocument.Path & "\员工表.docm")
rs = doc.Tables(1).Rows.Count - 1
Set ndoc = Documents.Add
Set tb = ndoc.Tables.Add(Selection.Range, rs / 2, 2)
For Each c In tb.Range.Cells
Set t = ndoc.Tables.Add(c.Range, 3, 2)
Set t = ndoc.Tables.Add(c.Range, 3, 2)
t.Style = "网格型"
n = n + 1
On Error GoTo 100
Set ts = doc.Tables(1).Rows(n + 1)
t.Cell(1, 1).Range = "编号：" & Split(ts.Cells(1).Range, Chr(13))(0)
t.Cell(2, 1).Range = "姓名：" & Split(ts.Cells(2).Range, Chr(13))(0)
t.Cell(3, 1).Range = "职务：" & Split(ts.Cells(3).Range, Chr(13))(0)
t.Columns(2).Cells.Merge
t.Cell(1, 2).Range.InlineShapes.AddPicture ThisDocument.Path & "\员工照\" & Split(ts.Cells(1).Range, Chr(13))(0) & "-" & Split(ts.Cells(2).Range, Chr(13))(0) & ".png"
t.Columns(1).Cells.DistributeHeight
t.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
t.Columns(1).Cells.VerticalAlignment = wdCellAlignVerticalCenter
Next
100
doc.Close
End Sub
38 表格的常用格式设置
'style
'Borders (n) '边框位置(-1到-8，上、左、下、右、横、竖、捺、撇)
'Borders(n).LineStyle = m '边框样式
'Borders(n).LineWidth = m '边框宽度
'Borders(n).color= m '边框颜色
'shading
Sub tedst()
With ActiveDocument.Tables(1)
With .Borders(-5)
.LineStyle = 7
.LineWidth = wdLineWidth300pt
.Color = RGB(200, 0, 0)
End With
.Shading.BackgroundPatternColor = wdColorYellow
End With
End Sub
第四部分
文本框部分跳过
第五部分
39 打开和关闭文档时间应用
打开文档的操作
Pricate Sub Document_Open()
Dim doc as Document
Set doc = Document.Open(ThisDocument.Path & "\info.docm")
With doc.Tables(1)
.Rows.Last.Select
Selection.InsertRowBelow 1
.Rows.Last.Cells(1).Range = Application.UserName
.Rows.Last.Cells(2).Range = ThisDocumentoc.Name
.Rows.Lase.Cells(3).Range = Now
End With
End Sub
关闭文档的操作
Private Sub Document_Close()
Documents("info.docm").Tables(1).Rows.last.cells(4).Range=Now
DOcuments("info.docm").Close -1
End Sub
40 word vba访问excel表格数据
Sub test()
Dim eapp As New Excel.Application, wb As Workbook, rng As Excel.Range
' Dim eapp2 As Object
' Set eapp2 = CreateObject("excel.application")
' Set wb = eapp.Workbooks.Open(ThisDocument.Path & "员工表。xlsx")
Set wb = eapp.Workbooks.Open("?E:\VBA\【数据】WordVBA视频教程完整版精通版\第6章 Word与Excel的双剑合壁\6.1 从excel中访问数据\员工表.xlsx")
eapp.Visible = True '是否显示'
For Each rng In wb.Worksheets("员工表").Range("h2", wb.Worksheets("员工表").Range("h1").End(xlDown))
If rng.Value = "本科" Then
rng.EntireRow.Range("a1:k1").Copy
Selection.Paste
End If
Next
'eapp2.Workbooks.Open
wb.Close 0
eapp.Quit
End Sub
41 word vba向excel写入数据
Option Explicit
Sub Demo()
Dim c As Cell, y%, n%, arr(), m%, ar
Dim eapp As New Excel.Application
With ThisDocument.Tables(1)
For Each c In .Columns(4).Cells
y = Val(Replace(c.Range, "岁", ""))
If y >= 40 Then
n = n + 1
ReDim Preserve arr(1 To n)
arr(n) = Split(c.Row.Range, Chr(13) & Chr(7))
End If
Next
End With
eapp.Workbooks.Open ThisDocument.Path & "\DEMO.xlsx"
eapp.Visible = True
MsgBox UBound(arr)
For Each ar In arr
m = m + 1
' 是以a1这格为基准，后面括号是偏移量，几行几列，resize是扩展几列
'比如eapp.Range("a1")(1, 1).Resize(1, 8) 就是 a1-a8
eapp.Range("a1")(m, 1).Resize(1, 8) = ar
Next
eapp.Workbooks("DEMO.xlsx").Close 1
End Sub
