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

    在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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11
    • 12
    • 13
    • 14
    • 15
    • 16
    • 17
    • 18
    • 19
    • 20
    • 21

    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11
    • 12
    • 13
    • 14
    • 15
    • 16
    • 17
    • 18
    • 19
    • 20
    • 21
    • 22
    • 23
    • 24
    • 25
    • 26
    • 27
    • 28
    • 29
    • 30
    • 31
    • 32
    • 33
    • 34
    • 35
    • 36
    • 37
    • 38
    • 39
    • 40
    • 41
    • 42
    • 43
    • 44
    • 45
    • 46
    • 47
    • 48
    • 49
    • 50
    • 51
    • 52
    • 53
    • 54
    • 55
    • 56
    • 57
    • 58
    • 59
    • 60
    • 61
    • 62
    • 63
    • 64
    • 65
    • 66
    • 67
    • 68
    • 69
    • 70
    • 71
    • 72
    • 73
    • 74
    • 75
    • 76
    • 77
    • 78
    • 79
    • 80
    • 81
    • 82
    • 83
    • 84
    • 85
    • 86
    • 87
    • 88
    • 89
    • 90
    • 91
    • 92
    • 93
    • 94
    • 95
    • 96
    • 97
    • 98
    • 99
    • 100
    • 101
    • 102
    • 103
    • 104
    • 105
    • 106
    • 107
    • 108
    • 109
    • 110
    • 111
    • 112
    • 113
    • 114
    • 115
    • 116
    • 117

    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11

    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10

    5. 段落缩进处理

    原因

    很多人习惯用空格来代替段首的缩进，然后经常出现空格数量不是2个，导致格式不美。
    我一般使用快捷键alt+s,s来设置缩进。针对有些表格里有乱七八糟的缩进，再用一个函数来取消缩进，设置快捷键alt+s,d

    代码

    Sub 缩进()
    With Selection.ParagraphFormat
        .CharacterUnitFirstLineIndent = 2
        .LeftIndent = 0
    End With
End Sub

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    Sub 缩进取消()
    With Selection.ParagraphFormat
        .CharacterUnitFirstLineIndent = 0
        .LeftIndent = 0
        .FirstLineIndent = CentimetersToPoints(0)
    End With
End Sub

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7

    6. 粘贴纯文本

    原因

    有时候复制别的文件里的内容，但只想要文字，不要格式。而用鼠标需要右键，选择纯文本粘贴，个人感觉太麻烦，换成快捷键：ctrl+shift+v

    代码

    Sub 粘贴保留文本()
   Selection.PasteAndFormat (wdFormatPlainText)
End Sub

    • 1
    • 2
    • 3

    7.设置打开文档的默认显示比例

    原因

    在现在的大显示屏下，word默认的100%的显示比例显然让文字太小了，一般现在都是放大后操作。个人的屏幕设置放大到130%合适，但每次都要去设置一遍就太麻烦了。利用代码设置每个文件打开后默认放大到130%。
    每个文档打开后默认会运行AutoOpen函数，不要修改这个名字。自己的操作可以写到这里。

    代码

    Sub AutoOpen()
    '设置打开文档的默认显示比例
    ActiveDocument.ActiveWindow.View.Zoom.Percentage = 130
    '设置打开文档修改默认背景色
    背景色设置
End Sub

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6

    PS：以上代码中的背景色设置是我上一遍的设置word护眼绿色的函数。

    8. 设置段落与下段同页

    原因

    用鼠标去操作这个太麻烦，要点N次才能找到，直接用快捷键代替，我是用的：ctrl+d

    代码

    Sub 与下段同页()
   Selection.Paragraphs.KeepWithNext = True
End Sub

    • 1
    • 2
    • 3

    9. 表格边框设置

    原因

    经常写报告的人可能会处理很多表格，常见的报告表格要嘛用粗边框，要嘛没有左右两侧的边框。为了不一个表格一个表格的去设置，采用代码控制，使用的时候只要鼠标点到表格内部任意位置，然后用快捷键设置格式。因为涉及多个函数，我用alt+b做引导，通过又快捷键控制，如设置表格重复标题行用alt+b,t。

    代码

    1. 重复标题行，选中要重复的标题行后按快捷键
    Sub 表格重复标题行()
   Selection.Rows.HeadingFormat = wdToggle
End Sub

    • 1
    • 2
    • 3
    1. 设置选中表格行高
    Sub 表格行高选中()
    Selection.Tables(1).Rows.HeightRule = wdRowHeightAtLeast
    Selection.Tables(1).Rows.Height = CentimetersToPoints(0.7)
End Sub

    • 1
    • 2
    • 3
    • 4
    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
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11
    • 12
    • 13
    • 14
    • 15
    • 16
    • 17
    • 18
    • 19
    • 20
    • 21
    • 22
    • 23
    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
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11
    • 12
    • 13
    • 14
    • 15
    • 16
    • 17
    • 18
    • 19
    • 20
    • 21
    • 22
    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11
    • 12
    • 13
    • 14
    • 15
    • 16
    • 17
    • 18
    • 19
    • 20
    • 21
    • 22
    • 23
    • 24
    • 25
    • 26

    当然，也可以一键完成整个文档的设置的，给一个参考代码：

    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8

    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11

    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

    • 1
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
    • 11
    • 12

    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
    • 2
    • 3
    • 4
    • 5
    • 6
    • 7
    • 8
    • 9
    • 10
  • 相关阅读:
    最强Python面试题之Python基础题
    C++11之decltype类型推导（使用场景、推导四规则、cv限定符）
    号称史上最难618，淘宝数据盘点你做对了吗？
    挠场的科学丨五、二十一世纪的挠力文明
    ARouter There is no route match the path 原因
    第一章 CIS 安全基准-网络访问控制
    python 之numpy 之随机生成数
    从源码深入理解读写锁(golang-RWMutex)
    242. 有效的字母异位词
    小程序中的分页查询
  • 原文地址：https://blog.csdn.net/erqie/article/details/128101183