在word中通过VBA编写一些常用的函数，再利用快捷键激发，可以有效的提高写作的效率。以下分享个人通过网络收集，或者改造，或者自己录制后修改的代码，有需要的可以自取。
因为已经记不清有些代码的出处了，如果有使用到你的代码，烦请告之添加引用说明或者我删除掉，谢谢！
1.字体设置
作用
针对常用报告里英文采用Times New Roman字体，而全选文档设置后会导致引号变成难看的英文形式，故引号单独设置为宋体。
代码
Sub 设置字体()
'数字、英文用Times,引号用宋体
ActiveDocument.Content.Font.Name = "Times New Roman"
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "[" & ChrW(8220) & ChrW(8221) & "]"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
.Replacement.Font.Name = "宋体"
End With
Selection.Find.Execute Replace:=wdReplaceAll
End Sub
2. 设置上下标
原因
对工科的报告来讲，经常报告里有需要设置上下标的地方，每次都要在报告里用鼠标（需要点N次），或者快捷键（不太方便按）的形式来设置，即不方便，还容易漏掉。
代码
Sub 设置上下标()
Application.ScreenUpdating = False
' SetSuperscriptAndSubscript "×10", "8"
' SetSuperscriptAndSubscript "×10", "4"
'单位
'SetSuperscriptAndSubscript "km", "2"
SetSuperscriptAndSubscript "m", "2" '会同时处理m2,km2,m2/s等
SetSuperscriptAndSubscript "m", "3" '会同时处理m3,m3/s等
' SetSuperscriptAndSubscript "ｍ", "3" '处理中文的m3
' SetSuperscriptAndSubscript "ｍ", "2" '处理中文的m3
'化学式
'SO42-
' SetSuperscriptAndSubscript "SO4", "2-"
'SetSuperscriptAndSubscript "SO", "4", "2-", False' SO42-
'HCO3-
'SetSuperscriptAndSubscript "HCO3", "-"
' SetSuperscriptAndSubscript "HCO", "3", "-", False
'H2S,h2sio4
' SetSuperscriptAndSubscript "H", "2", "S", False
'SetSuperscriptAndSubscript "H2SIO", "4", "", False
'O2,co2,NO2
' SetSuperscriptAndSubscript "O", "2", "", False
' SetSuperscriptAndSubscript "Fe", "2", "O", False
' SetSuperscriptAndSubscript "O", "3", "", False
' SetSuperscriptAndSubscript "P", "2", "O", False
' SetSuperscriptAndSubscript "O", "5", "", False
' SetSuperscriptAndSubscript "H", "2", "", False
'N2
'SetSuperscriptAndSubscript "N", "2", "", False
'CH4,NH4
' SetSuperscriptAndSubscript "CH", "4", "", False
' SetSuperscriptAndSubscript "NH", "4", "", False
'NH3-n
SetSuperscriptAndSubscript "NH", "3", "-N", False
'BOD5
SetSuperscriptAndSubscript "BOD", "5", "", False
'CODMN
' SetSuperscriptAndSubscript "COD", "Mn", "", False
' SetSuperscriptAndSubscript "COD", "Cr", "", False
'Na+
' SetSuperscriptAndSubscript "Na", "+", ""
'K+
' SetSuperscriptAndSubscript "K", "+", ""
'Ca2+
' SetSuperscriptAndSubscript "Ca", "2+", ""
'Mg2+
' SetSuperscriptAndSubscript "Mg", "2+", ""
'H+
' SetSuperscriptAndSubscript "H", "+", ""
'Cr6+
' SetSuperscriptAndSubscript "Cr", "6+", ""
' SetSuperscriptAndSubscript "S", "i", "", False
' SetSuperscriptAndSubscript "CaCO", "3", "", False
' SetSuperscriptAndSubscript "Al", "2", "O", False
Application.ScreenUpdating = True
End Sub
Private Sub SetSuperscriptAndSubscript(ByVal PrefixChr As String, ByVal SetChr As String, Optional ByVal PostChr As String, Optional ByVal SuperscriptMode As Boolean = True)
'程序功能：设置文档中特定字符为上标或下标。
'参数说明：
'PrefixChr：必选参数，要设置为上、下标字符之前的字符；
'SetChr：必选参数，要设置为上、下标的字符；
'PostChr:必选,但可赋空字符串,若为了界定整个替换符号而包含的后缀,防止误替换,可加此参数
'SuperscriptMode：可选参数，设置为 True 表示将 SetChr 设置为上标，设置为 False 表示将 SetChr 设置为下标，默认为 True。
'举例说明：
'我们要将文档中所有的“m3/s”中的“3”设置为上标，可通过下面这一行代码调用本程序完成：
'SetSuperscriptAndSubscript "M","3" '这里设置上标，可省略第三个参数。
Selection.Start = ActiveDocument.Paragraphs(1).Range.Start '将光标定位至活动文档第一段落段首的位置
Selection.Collapse wdCollapseStart '折叠至起始位置
With Selection.Find
'先把整个字符换成上、下标
.ClearFormatting
.Replacement.ClearFormatting
.Text = PrefixChr & SetChr & PostChr
.Replacement.Text = .Text
If SuperscriptMode Then
.Replacement.Font.Superscript = True
Else
.Replacement.Font.Subscript = True
End If
.Execute Replace:=wdReplaceAll
'再把前面的内容换成原来正常的文本
.ClearFormatting
.Replacement.ClearFormatting
.Text = PrefixChr
If SuperscriptMode Then
.Font.Superscript = True
Else
.Font.Subscript = True
End If
.Replacement.Text = .Text
If SuperscriptMode Then
.Replacement.Font.Superscript = False
Else
.Replacement.Font.Subscript = False
End If
.Execute Replace:=wdReplaceAll
'再把后面的内容换成原来正常的文本
If Len(PostChr) > 0 Then
.ClearFormatting
.Replacement.ClearFormatting
.Text = PostChr
If SuperscriptMode Then
.Font.Superscript = True
Else
.Font.Subscript = True
End If
.Replacement.Text = .Text
If SuperscriptMode Then
.Replacement.Font.Superscript = False
Else
.Replacement.Font.Subscript = False
End If
.Execute Replace:=wdReplaceAll
End If
End With
End Sub
PS:用到的SetSuperscriptAndSubscript函数好像是从网上找到的，具体作者忘记了，感谢！
3. 替换粘贴的内容
原因
经常从PDF文件或者网上复制的内容下来会有很多的空格，多余的回车，我个这个函数，配合alt+f快捷键，来快速的删除与替换相应的符号。主要包括空格、英文逗号、英文分号等。
代码
Sub 替换粘贴()
'delete the space
Selection.Find.Execute findtext:=" ", replacewith:="", Replace:=wdReplaceAll, Wrap:=wdFindStop
'replace the english comma to chinese comma
Selection.Find.Execute findtext:=",", replacewith:="，", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:=";", replacewith:="；", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:=":", replacewith:="：", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="(", replacewith:="（", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:=")", replacewith:="）", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="^p", replacewith:="", Replace:=wdReplaceAll, Wrap:=wdFindStop, MatchWildcards:=False
End Sub
4. 替换中文的单位
原因
有时候参考的老资料很多时候习惯用中文的单位，导致报告里的单位一会儿中文一会儿英文，为了统一，直接全部替换成英文的。
通过以下函数运行后，再运行上下标函数可实现上下标的修改。
代码
Sub 替换中文单位()
Selection.Find.Execute findtext:="平方米", replacewith:="m2", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="平方千米", replacewith:="km2", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="平方公里", replacewith:="km2", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="立方米", replacewith:="m3", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="公里", replacewith:="km", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="千米", replacewith:="km", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="厘米", replacewith:="cm", Replace:=wdReplaceAll, Wrap:=wdFindStop
Selection.Find.Execute findtext:="毫米", replacewith:="mm", Replace:=wdReplaceAll, Wrap:=wdFindStop
End Sub
5. 段落缩进处理
原因
很多人习惯用空格来代替段首的缩进，然后经常出现空格数量不是2个，导致格式不美。
我一般使用快捷键alt+s,s来设置缩进。针对有些表格里有乱七八糟的缩进，再用一个函数来取消缩进，设置快捷键alt+s,d
代码
Sub 缩进()
With Selection.ParagraphFormat
.CharacterUnitFirstLineIndent = 2
.LeftIndent = 0
End With
End Sub
Sub 缩进取消()
With Selection.ParagraphFormat
.CharacterUnitFirstLineIndent = 0
.LeftIndent = 0
.FirstLineIndent = CentimetersToPoints(0)
End With
End Sub
6. 粘贴纯文本
原因
有时候复制别的文件里的内容，但只想要文字，不要格式。而用鼠标需要右键，选择纯文本粘贴，个人感觉太麻烦，换成快捷键：ctrl+shift+v
代码
Sub 粘贴保留文本()
Selection.PasteAndFormat (wdFormatPlainText)
End Sub
7.设置打开文档的默认显示比例
原因
在现在的大显示屏下，word默认的100%的显示比例显然让文字太小了，一般现在都是放大后操作。个人的屏幕设置放大到130%合适，但每次都要去设置一遍就太麻烦了。利用代码设置每个文件打开后默认放大到130%。
每个文档打开后默认会运行AutoOpen函数，不要修改这个名字。自己的操作可以写到这里。
代码
Sub AutoOpen()
'设置打开文档的默认显示比例
ActiveDocument.ActiveWindow.View.Zoom.Percentage = 130
'设置打开文档修改默认背景色
背景色设置
End Sub
PS：以上代码中的背景色设置是我上一遍的设置word护眼绿色的函数。
8. 设置段落与下段同页
原因
用鼠标去操作这个太麻烦，要点N次才能找到，直接用快捷键代替，我是用的：ctrl+d
代码
Sub 与下段同页()
Selection.Paragraphs.KeepWithNext = True
End Sub
9. 表格边框设置
原因
经常写报告的人可能会处理很多表格，常见的报告表格要嘛用粗边框，要嘛没有左右两侧的边框。为了不一个表格一个表格的去设置，采用代码控制，使用的时候只要鼠标点到表格内部任意位置，然后用快捷键设置格式。因为涉及多个函数，我用alt+b做引导，通过又快捷键控制，如设置表格重复标题行用alt+b,t。
代码
- 重复标题行，选中要重复的标题行后按快捷键
Sub 表格重复标题行()
Selection.Rows.HeadingFormat = wdToggle
End Sub
- 设置选中表格行高
Sub 表格行高选中()
Selection.Tables(1).Rows.HeightRule = wdRowHeightAtLeast
Selection.Tables(1).Rows.Height = CentimetersToPoints(0.7)
End Sub
- 粗边框去侧边线
Sub 表格粗边框去侧边线()
Application.ScreenUpdating = False
With Selection.Tables(1)
With .Borders(wdBorderVertical)
.LineStyle = wdLineStyleSingle
End With
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleNone
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleNone
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
End With
Application.ScreenUpdating = True
End Sub
- 粗边框
Sub 表格粗边框选中()
Application.ScreenUpdating = False
With Selection.Tables(1)
With .Borders(wdBorderLeft)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
With .Borders(wdBorderRight)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
With .Borders(wdBorderBottom)
.LineStyle = wdLineStyleSingle
.LineWidth = wdLineWidth150pt
End With
End With
Application.ScreenUpdating = True
End Sub
- 用得比较多的一个整体的设置，一般设置alt+b,g，一键完成表格格式设置
Sub 表格设置格式()
Dim t As Table, s As Range
Set t = Selection.Tables(1)
'Set s = t.Rows(1).Range
'With s.Font
' .Bold = True '表头加粗
'End With
'段落水平居中
t.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
'段落垂直居中
t.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'设置字号
t.Range.Font.Size = 10.5 '小5：9，5号：10.5，小四：12，四号：14,
t.Range.Font.Name = "宋体"
t.Range.Font.Name = "Times New Roman"
'单倍行距
t.Range.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
'根据窗口自动调整表格
t.AutoFitBehavior (wdAutoFitWindow)
'根据内容自动调整表格
t.AllowAutoFit = False
表格行高选中
'表格粗边框选中
表格粗边框去侧边线
缩进取消
End Sub
当然，也可以一键完成整个文档的设置的，给一个参考代码：
Sub 表格行高全文()
Application.ScreenUpdating = False
For i = 1 To ActiveDocument.Tables.Count
ActiveDocument.Tables(i).Rows.HeightRule = wdRowHeightAtLeast
ActiveDocument.Tables(i).Rows.Height = CentimetersToPoints(0.7)
Next
Application.ScreenUpdating = True
End Sub
10.设置图片大小
原因
如果文档中图片过多，一个一个去调整大小很麻烦。
代码
Sub 图片大小全文()
Mywidth = 7 '10为图片宽度（厘米）
Myheigth = 5.2 '5.2为图片高度（厘米）
Application.ScreenUpdating = False
For Each ishape In ActiveDocument.InlineShapes '嵌入型图片
ishape.LockAspectRatio = msoFalse '不锁定纵横比
ishape.Height = 28.345 * Myheigth '单位换算也可以用CentimetersToPoints()函数
ishape.Width = 28.345 * Mywidth
Next ishape
Application.ScreenUpdating = True
End Sub
PS:大小可以调整，这个参数合适双栏图片
给全文档的图片加一个边框：
Sub 图片边框全文()
Dim oInlineShape As InlineShape
Application.ScreenUpdating = False
For Each oInlineShape In ActiveDocument.InlineShapes
With oInlineShape.Borders
.OutsideLineStyle = wdLineStyleSingle
.OutsideColorIndex = wdColorAutomatic
.OutsideLineWidth = wdLineWidth025pt
End With
Next
Application.ScreenUpdating = True
End Sub
11.关于文档背景颜色的设置
原因
win10过后设置系统的护眼颜色在word里失效了，采用一个曲线办法：
代码
Sub 背景色设置()
ActiveDocument.Background.Fill.Visible = msoTrue
ActiveDocument.Background.Fill.ForeColor.RGB = RGB(204, 232, 207)
ActiveDocument.Background.Fill.Solid
ActiveDocument.ActiveWindow.View.DisplayBackgrounds = True
End Sub
Sub 背景色取消()
ActiveDocument.Background.Fill.Visible = msoFalse
End Sub
更多推荐
分享个人收集或整理的word中常用的vba代码
发布评论