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

shouzhuw 2024-09-03 发布于四川

展开全文

在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