利用vba排版1.docx
《利用vba排版1.docx》由会员分享，可在线阅读，更多相关《利用vba排版1.docx（14页珍藏版）》请在冰豆网上搜索。
利用vba排版1
目录
目录
目录1
一.使用VBA处理表格2
实例1：
将每个表格在文档中的以页面为基准居中对齐2
实例2：
将每个表格中的所有文本在单元格中自动居中对齐2
实例3：
删除文档中的所有表格3
实例4：
删除文档中的所有表格包含的空行3
实例5：
在表格第一列的每个单元格中插入指定的图片4
实例6：
自动将文档中的每个表格上方的标题汇总到新文档中5
实例7：
下面的代码一次性删除文档中所有表格的内外边框线和底纹效果6
实例8：
统一设置所有表格标题行的底纹颜色7
实例9：
统一设置所有表格的边框线样式8
二.使用VBA处理图片和图形对象10
实例1：
将所有图片的宽度统一设置为7厘米10
实例2：
快速为所有图片添加边框10
实例3：
下面的代码将文档中的所有图形填充色设置为红色11
实例4：
快速改变所有文本框中的字体颜色12
实例5：
批量删除文档中的所有图片12
实例6：
批量删除文档中的所有自选图形12
实例7：
批量删除文档中的所有文本框13
三．使用VBA处理文本13
实例1：
快速将指定内容提取到新文档中13
实例2：
批量设置不连续文本的格式15
实例3：
批量设置不连续段落的格式15
实例4：
快速删除文档中的所有空行16
一.使用VBA处理表格
实例1：
将每个表格在文档中的以页面为基准居中对齐
代码：
Sub将每个表格在文档中以页面为基准居中对齐（）
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Rows.Alignment=wdAlignRowCenter
Nexttbl
Settbl=Nothing
EndSub
代码解析：
Table对象的Rows代表表格中的所有行。
Rows集合的Aligment属性用于设置整个表格在页面中的对齐方式：
wdAlignRowCenter居中（wdAlignRowLeft左对齐默认值，wdAlignRowRight右对齐）
实例2：
将每个表格中的所有文本在单元格中自动居中对齐
代码：
Sub将每个表格中的所有文本在单元格中自动居中对齐（）
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Range.ParagraphFormat.Alignment=wdAlignParagraphCenter
Nexttbl
Settbl=Nothing
EndSub
代码解析：
Table对象的Range属性返回一个Range对象，代表一个表格在文档中的范围，使用Range对象的ParagphForment属性返回一个ParagraphFormat对象，用于设置表格内容的段落格式，ParagraphFormat对象的Aligement属性用于设置段落的对齐方式。
实例3：
删除文档中的所有表格
代码：
Sub删除文档中的所有表格（）
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Delete
Nexttbl
Settbl=Nothing
EndSub
实例4：
删除文档中的所有表格包含的空行
代码：
Sub删除文档中的所有表格包含的空行（）
DimtblAsTable
DimiRowAsInteger
ForEachtblInActiveDocument.Tables
ForiRow=tbl.Rows.CountTo1Step-1
IfLen（tbl.Rows（iRow）.Range.Text）=（tbl.Columns.Count+1）*2Then
tbl.Rows（iRow）.Delete
EndIf
NextiRow
Nexttbl
Settbl=Nothing
EndSub
代码解析：
表格中的一个空白单元格的长度为2=1个段落标记+1个表格边框线，每行最后一个单元格右侧，也就是位于表格外侧还有一个段落标记，该段落标记的长度也为2，因此，需要检测每行的总长度是否等于（表格列数+1）X2如果是则说明该行为空行，否则不是空行，Len（tbl.Rows（iRow）.Range.Text）语句表示表格某行包含文本的总长度
实例5：
在表格第一列的每个单元格中插入指定的图片
自动插入6张照片第一个表格中的第一列的每个单元格中，6张图片和表格所属的文档位于同一个文件夹中。
代码：
Sub在表格第一列的每个单元格中插入指定的图片（）
DimiAsInteger
DimvPicAsVariant
DimsFullNameAsString
DimtblAsTable
OnErrorResumeNext
Settbl=ActiveDocument.Tables
（1）
IfErr.Number<>0Then
MsgBox"请先创建一个不少于6行的表格"
ExitSub
EndIf
vPic=Array（"辣椒","胡萝卜","西红柿","柚子","草莓","猕猴桃"）
Fori=LBound（vPic）ToUBound（vPic）
sFullName=tbl.Parent.Path&"\"&vPic（i）&".jpg"
tbl.Columns
（1）.Cells（i+1）.Range.InlineShapes.AddPicturesFullName
Nexti
Settbl=Nothing
EndSub
实例6：
自动将文档中的每个表格上方的标题汇总到新文档中
如果文档中的每个表格上面的一行都包含一个标题，下面的代码将与每个表格相关的标题提取到一个新文档中
代码：
Sub自动将文档中的每个表格上方的标题汇总到新文档中（）
DimtblAsTable
DimrngAsRange
DimsTitleAsString
ForEachtblInActiveDocument.Tables
Setrng=ActiveDocument.Range（tbl.Range.Start-1,tbl.Range.Start-1）
rng.Expand（wdParagraph）
sTitle=sTitle&rng.Text
Nexttbl
Documents.Add
Selection.Text=sTitle
Settbl=Nothing
Setrng=Nothing
EndSub
代码解析：
代码中声明了三个变量，tbl变量常用于遍历文档中的每一个表格，rng变量用于指定表格上方的标题范围，sTitle变量用于保存所有表格的标题，使用tbl变量遍历当前文档的每一个表格，在遍历每个单元格时，定义rng变量的范围为表格上方的段落的结尾位置，tbl.Range返回整个表格在文档中的范围，tbl.Range.Start返回表格的起始位置，将该值减1得到上一个段落结尾的位置，使用Range对象的Expand方法将rng变量中定义范围拓展到整个段落，然后将rng变量所表示的范围中的内容赋值给sTitle变量，在文档的每个表格中重复以上操作，最后将Stitle变量中保存的所有表格的标题写入新建的文档中。
实例7：
下面的代码一次性删除文档中所有表格的内外边框线和底纹效果
代码：
Sub删除打开的所有文档中所有表格的内外边框线和底纹效果（）
DimdocAsDocument
DimtblAsTable
ForEachdocInDocuments
ForEachtblIndoc.Tables
tbl.Borders.OutsideLineStyle=wdLineStyleNone
tbl.Borders.InsideLineStyle=wdLineStyleNone
tbl.Rows
（1）.Shading.BackgroundPatternColor=wdColorAutomatic
Nexttbl
Nextdoc
Setdoc=Nothing
Settbl=Nothing
EndSub
实例8：
统一设置所有表格标题行的底纹颜色
下面的代码自动将当前文档中的所有表格的标题行设置灰色底纹
代码：
Sub统一设置所有表格标题行的底纹颜色（）
DimtblAsTable
ForEachtblInActiveDocument.Tables
tbl.Rows
（1）.Shading.BackgroundPatternColor=wdColorGray15
Nexttbl
Settbl=Nothing
EndSub
代码解析：
Table对象的Ros属性代表表格中的所有行，使用Rows
（1）引用表格的第一行同时返回一个Row对象，然后使用Row对象的Shading属性设置表格的底纹效果。
本例中的wdColorGray15表示12%灰度，更多颜色：
常量值说明
wdColorAutomatic自动配色，默认值。
一般取决于文档的主题颜色
wdColorGray055%灰色底纹
wdColorGray1010%灰色底纹
wdColorGray12512.5%灰色底纹
wdColorGray37537.5%灰色底纹（其他量值改下数据就可以）
wdColorBlue蓝色
wdColorBlack黑色
wdColorBrown褐色
wdColorRed红色
wdColorGreen绿色
wdColorYellow黄色
wdColorViolet紫色（其他颜色一样设置，查下颜色的英语就可以）
实例9：
统一设置所有表格的边框线样式
下面代码将当前表格的外边框线设置为1.5磅宽的单线，将内边框线设置为1磅的点划线
代码：
Sub统一设置所有表格的边框线样式（）
DimtblAsTable
ForEachtblInActiveDocument.Tables
Withtbl.Borders
.OutsideLineStyle=wdLineStyleSingle
.OutsideLineWidth=wdLineWidth150pt
.InsideLineStyle=wdLineStyleDashDot
.InsideLineWidth=wdLineWidth100pt
EndWith
Nexttbl
Settbl=Nothing
EndSub
代码解析：
设置表格边框线线型需要使用WdlineStyle常量，该常量的取值情况：
常量值说明
wdLineStyleNone无边框
wdLineStyleSingle单实线
wdLineStyleDouble双实线
wdLineStyleTriple三条细实线
wdLineStylesingleWavy波浪型单实线
wdLineStyleDot点
wdLineStyleDashDot划线后跟单个点
wdLineStyleDashDotDot划线后跟两个点
wdLineStyleDashDotStroked划线后跟粗点
表格边框线宽度的WdlineWidth常量的取值情况：
常量值说明
wdlineWidth025pt0.25磅
wdlineWidth050pt0.5磅
wdlineWidth075pt0.75磅
wdlineWidth100pt1磅，默认值
wdlineWidth150pt1.5磅
其他磅值类似，同学们自己改下数字就可以了，要学会举一反三
二.使用VBA处理图片和图形对象
实例1：
将所有图片的宽度统一设置为7厘米
代码：
Sub将所有图片的宽度统一设置为7厘米（）
DimInShpAsInlineShape
ForEachInShpInActiveDocument.InlineShapes
WithInShp
If.Type=wdInlineShapePictureThen
.LockAspectRatio=msoTrue
.Width=CentimetersToPoints（7）
EndIf
EndWith
NextInShp
SetInShp=Nothing
EndSub
代码解析：
声明一个InlineShape类型的对象变量InShp，使用该变量遍历文档中的所有嵌入型的对象，通过InlineShape对象的Type属性判断InShp变量当前引用的对象是否是图片，如果是则锁定图片的宽高比，然后将图片宽度设置成7厘米。
实例2：
快速为所有图片添加边框
代码：
Sub快速为所有图片添加边框（）
DimInShpAsInlineShape
ForEachInShpInActiveDocument.InlineShapes
WithInShp
If.Type=wdInlineShapePictureThen
.Borders.Enable=True
EndIf
EndWith
NextInShp
SetInShp=Nothing
EndSub
代码解析：
使用InShp变量在文档中遍历图片的方法与上面讲的类似，将InlineShape对象的Borders属性设置为True表示为图片应用默认边框。
实例3：
下面的代码将文档中的所有图形填充色设置为红色
代码：
Sub快速为所有形状设置填充色（）
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Withshp
If.Type=msoAutoShapeThen
.Fill.ForeColor=vbRed
EndIf
EndWith
Nextshp
Setshp=Nothing
EndSub
代码解析：
声明一个Shape类型的变量shp,使用该变量遍历当前文档中的每一个浮动型对象，然后使用Shape对象的Type属性判断shp变量当前引用的对象是否是自选图形，如果是则将该图形的前景设置为红色。
实例4：
快速改变所有文本框中的字体颜色
统一将文本框的文字颜色设置为蓝色
代码：
Sub快速改变所有文本框中的字体颜色（）
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Ifshp.Type=msoTextBoxThen
shp.TextFrame.TextRange.Font.ColorIndex=wdBlue
EndIf
Nextshp
Setshp=Nothing
EndSub
代码解析:
声明一个Shape类型的变量shp，使用该变量遍历当前文档中的每一个浮动型对象，然后使用Shape对象的Type属性判断shp变量当前引用的对象是否是文本框，如果是则该文本框的文字颜色设置为蓝色。
（wdBlue中的Blue同学可以更改成需要的颜色）
实例5：
批量删除文档中的所有图片
代码：
Sub批量删除文档中的所有图片（）
DimInShpAsInlineShape
ForEachInShpInActiveDocument.InlineShapes
IfInShp.Type=wdInlineShapePictureThen
InShp.Delete
EndIf
NextInShp
SetInShp=Nothing
EndSub
实例6：
批量删除文档中的所有自选图形
代码：
Sub批量删除文档中的所有自选图形（）
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Ifshp.Type=msoAutoShapeThen
shp.Delete
EndIf
Nextshp
Setshp=Nothing
EndSub
实例7：
批量删除文档中的所有文本框
代码：
Sub批量删除文档中的所有文本框（）
DimshpAsShape
ForEachshpInActiveDocument.Shapes
Ifshp.Type=msoTextBoxThen
shp.Delete
EndIf
Nextshp
Setshp=Nothing
EndSub
三．使用VBA处理文本
实例1：
快速将指定内容提取到新文档中
下面的代码将当前文档中包含“word”一词中的所有句子提取到一个新文档中。
代码：
Sub快速将指定内容提取到新文档中（）
DimsFindTextAsString
WithSelection
.HomeKeywdStory
With.Find
.ClearFormatting
.Text="Word"
.MatchCase=True
.Forward=True
Do
.Execute
If.Found=FalseThenExitDo
.Parent.Expand（wdSentence）
sFindText=sFindText&Selection.Text&vbCrLf
.Parent.CollapsewdCollapseEnd
Loop
EndWith
EndWith
Documents.Add
Selection.Text=sFindText
EndSub代码解析：
先使用Selection的HomeKey方法将插入点移至文档开头，然后设置查找条件，查找Word一词严格要求匹配大小写，接着使用DoLoop循环按照设置好的条件反复查找指定的内容，使用Find对象的Found属性判断是否找到匹配项，如果未找到则退出DoLoop循环，如果找到匹配项会自动选中该内容，然后将选区拓展到该词所在的句子，同时将每次找到并拓展后的内容存入sFindText变量中，然后将选区折叠到结尾处，继续进行查找，最后新建一个文档，将所有找到的内容输入到新文档中。
更灵活的做法是运行程序后显示一个对话框，允许用户输入要提取的内容，然后根据输入的内容提取相应范围中的内容，而不是将要提取的内容输入到代码中，从而形成缺少灵活性的硬编码，下面是修改后的代码，使用VBA的InputBox函数所创建的对话框接受用户输入的内容，然后检测输入的内容是否为空或者直接单击对话框中的取消按钮，如果是则退出程序，否则在文档中查找输入的内容，找到匹配项则进行提取。
代码：
Sub快速将指定内容提取到新文档中2（）
DimsFindTextAsString,sAnsAsString
sAns=InputBox（"请输入要提取的关键字","自动提取内容"）
IfsAns=""ThenExitSub
WithSelection
.HomeKeywdStory
With.Find
.ClearFormatting
.Text=sAns
.MatchCase=True
.Forward=True
Do
.Execute
If.Found=FalseThenExitDo
.Parent.Expand（wdSentence）
sFindText=sFindText&Selection.Text&vbCrLf
.Parent.CollapsewdCollapseEnd
Loop
EndWith
EndWith
Documents.Add
Selection.Text=sFindText
EndSub
实例2：
批量设置不连续文本的格式
下面的代码将当前文档第一段中的第一段中的1、3、5、7、9这几个序列的文字字体设置为红色并加粗显示
代码：
Sub批量设置不连续文本的格式（）
DimavWordAsVariant,iAsInteger
avWord=Array（1,3,5,7,9）
Fori=LBound（avWord）ToUBound（avWord）
WithActiveDocument
With.Paragraphs
（1）.Range.Words（avWord（i））.Font
.ColorIndex=wdRed
.Bold=True
EndWith
EndWith
Nexti
EndSub
实例3：
批量设置不连续段落的格式
下面的代码会将文档中的第1、3、6段的大纲级别设置成1级。
代码：
Sub批量设置不连续段落的格式（）
DimavParaAsVariant,iAsInteger
avPara=Array（1,3,6）
Fori=LBound（avPara）ToUBound（avPara）
WithActiveDocument
.Paragraphs（avPara（i））.Range.ParagraphFormat.OutlineLevel=wdOutlineLevel1
EndWith
Nexti
EndSub
实例4：
快速删除文档中的所有空行
代码:
Sub快速删除文档中的所有空行（）
DimparaAsParagraph
Application.ScreenUpdating=False
ForEachparaInActiveDocument.Paragraphs
IfLen（para.Range）=1Then
para.Range.Delete
EndIf
Nextpara
Application.ScreenUpdating=True
EndSub
代码解析:
空行其实就是只包含一个段落标记的空白段落，因此可以通过判断一个段落的长度来确定是否是一个空白段落，如果段落长度为1，则说明该段落只要一个段落标记，通过使用一个Paragraph类型的对象变量，遍历文档中的每一个段落并判断段落的长度是否为1，如果是则说明该段落只包含一个段落标记，将其删除即可。
升级会员 