分享个人收集或整理的word中常用的vba代码

本文分享了一系列使用VBA在Microsoft Word中提高写作效率的代码示例,包括字体设置、上下标设置、替换粘贴内容、替换中文单位、段落缩进处理、粘贴纯文本、设置打开文档默认显示比例、与下段同页、表格边框设置等功能。这些代码可以通过快捷键激活,大大简化了常用操作,尤其适合经常处理技术文档的用户。
摘要由CSDN通过智能技术生成

在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 "m", "3"           '处理中文的m3
   '    SetSuperscriptAndSubscript "m", "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。

代码

  1. 重复标题行,选中要重复的标题行后按快捷键
Sub 表格重复标题行()
   Selection.Rows.HeadingFormat = wdToggle
End Sub
  1. 设置选中表格行高
Sub 表格行高选中()
    Selection.Tables(1).Rows.HeightRule = wdRowHeightAtLeast
    Selection.Tables(1).Rows.Height = CentimetersToPoints(0.7)
End Sub
  1. 粗边框去侧边线
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
  1. 粗边框
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
  1. 用得比较多的一个整体的设置,一般设置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
评论 1
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值