分享個人收集或整理的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

本站是提供個人知識管理的網絡存儲空間，所有內容均由用戶發布，不代表本站觀點。請注意甄別內容中的聯系方式、誘導購買等信息，謹防詐騙。如發現有害或侵權內容，請點擊一鍵舉報。