Word下的几个VBA代码

删除文档中所有内容为空的行
Sub DelBlank()

Dim i as Paragraph, n as Long
Application.ScreenUpdating = False
For Each i In ActiveDocument.Paragraphs
    If Len(i.Range) = 1 Then
        i.Range.Delete
        n = n + 1
    End If
Next
MsgBox "共删除空白段落" & n & "个。"
Application.ScreenUpdating = True

End Sub
删除文档中的隐藏文字
Sub test()
n = 0
ActiveDocument.ActiveWindow.View.ShowHiddenText = True
For Each i In ActiveDocument.Characters
If i.Font.Hidden = True Then
n = n + 1
i.Delete
End If
Next
MsgBox "共删除隐藏字符" & n & "个"
End Sub
删除空格
Sub 删除空格()
Dim FindChar As String, Fcount As Integer, RepChar As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
FindChar = " "
RepChar = ""
With ActiveDocument.Content.Find '此处针对全文档

Do While .Execute(findtext:=FindChar) = True '如果发现
Fcount = Fcount + 1 '计数器
Loop
    If MsgBox("文档中共发现了" & Fcount & "个" & FindChar & vbCrLf _

& ",按Yes键将进行下一步的替换工作,按No取消", vbYesNo + vbInformation) = vbYes Then

 .Execute findtext:=FindChar, Wrap:=wdFindContinue, replacewith:=RepChar, Replace:=wdReplaceAll
 End If

End With
Application.ScreenUpdating = True
'恢复屏幕更新
End Sub
段首空格删除
Sub 删除段首空格1()
Selection.WholeStory 'CTR+A
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter 'CTR+E
Selection.ParagraphFormat.Reset 'CTR+Q
End Sub
Sub 删除段首空格2()

 Dim i As Paragraph, n As Long
 Application.ScreenUpdating = False '关闭屏幕刷新
 For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环
       For n = 1 To i.Range.Characters.Count
           If i.Range Like " *" _
           Or i.Range Like "　*" Then
              i.Range.Characters(1).Delete
            Else: Exit For
            End If
         Next n
    Next
   Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

Sub 删除段首空格3()

  Dim i As Paragraph, n As Long
  Application.ScreenUpdating = False '关闭屏幕刷新
  For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环
       For n = 1 To i.Range.Characters.Count
           If i.Range.Characters(1).Text = " " _
           Or i.Range.Characters(1).Text = "　" Then
              i.Range.Characters(1).Delete
           Else: Exit For
           End If
        Next n
   Next
  Application.ScreenUpdating = True '恢复屏幕刷新
 End Sub

删除空白段落
'功能简介:可以对指定长度的段落进行删除，当LEN=1时
'可对空白段落进行删除。'
'* ---------------------------------------
Sub 删除空段()
Dim i As Paragraph, n As Long
Call 删除段首空格2 '调用工程
Application.ScreenUpdating = False '关闭屏幕刷新
For Each i In ActiveDocument.Paragraphs '在活动文档的段落集合中循环
If Len(i.Range) = 1 Then '判断段落长段,此处可根据文档实际情况
i.Range.Delete '进行必要的修改可将任意长度段落删除
n = n + 1 '计数
End If
Next
MsgBox "共删除空白段落" & n & "个!"
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub
设置段落格式
Sub 设置段落格式()
Dim pa As Paragraph
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
For Each pa In ActiveDocument.Paragraphs

  pa.Format.CharacterUnitFirstLineIndent = 2

Next
With ActiveDocument.Content.Font

.Name = "楷体_GB2312"
.Size = 14

End With
Application.ScreenUpdating = True '恢复屏幕更新
End Sub
设置大纲级别
'* +++++++++++++++++++++++++++++++++++++++
'实现以日期2010开头的段落，第一句加粗的代码，
'并将该段落升为一级大纲。'
'* ----------------------------------------
Sub 设置大纲1()
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
For RQJC = 1 To ActiveDocument.Range(0, ActiveDocument.Range.End).Paragraphs.Count '对正文全文段落进行循环

With ActiveDocument.Paragraphs(RQJC).Range
If ActiveDocument.Range(.Start, .Start + 4).Text = "2010" Then '当每一段落前四个字符以“2010”开头
.Sentences(1).Font.Bold = True '每一段第一句字体加粗
ActiveDocument.Paragraphs(RQJC).OutlineLevel = wdOutlineLevel1 '该段落的大纲级别变为一级大纲
End If
End With

Next RQJC
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

'* +++++++++++++++++++++++++++++++++++++++

'字符数小于41的段落，第一句加粗，
'并将该段落升为二级大纲。'
'* -------------------------------------------
Sub 设置大纲2()
  Dim n As Long, i As Paragraph
  On Error Resume Next
  Application.ScreenUpdating = False  '关闭屏幕更新
  For n = 1 To ActiveDocument.Paragraphs.Count
    If ActiveDocument.Paragraphs(n).Range.Characters.Count < 41 _
    And ActiveDocument.Paragraphs(n).Range.Characters.Count > 0 Then '段落字符数小于41,约为一两行
    ActiveDocument.Paragraphs(n).Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗
    ActiveDocument.Paragraphs(n).OutlineLevel = wdOutlineLevel2 '该段落的大纲级别变为二级大纲
    End If
  Next n
  Application.ScreenUpdating = True  '恢复屏幕更新
 End Sub

'* +++++++++++++++++++++++++++++++++++++++
'以数字开头的段落，第一句加粗，
'并将该段落升为二、三级大纲。'
'* ------------------------------------------
Sub 设置大纲3()
Dim pa As Paragraph, MyStr1 As String, MyStr2 As String, MyStr3 As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
Call 删除段首空格3 '调用工程
MyStr1 = "第一二三四五六七八九十" '假定为手动加注每个段落开头为中文大写数字
MyStr2 = "123456789" '假定为手动加注每个段落开头为数字，半角
MyStr3 = "１２３４５６７８９" '假定为手动加注每个段落开头为数字，全角
For Each pa In ActiveDocument.Paragraphs

If InStr(MyStr1, ActiveDocument.Range(pa.Range.Start, pa.Range.Start + 1).Text) > 0 Then
pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗
pa.OutlineLevel = wdOutlineLevel2 '该段落的大纲级别变为二级大纲
End If
If InStr(MyStr2, ActiveDocument.Range(pa.Range.Start, pa.Range.Start + 1).Text) > 0 Then
pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗
pa.OutlineLevel = wdOutlineLevel3 '该段落的大纲级别变为三级大纲
End If
If InStr(MyStr3, ActiveDocument.Range(pa.Range.Start, pa.Range.Start + 1).Text) > 0 Then
pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗
pa.OutlineLevel = wdOutlineLevel3 '该段落的大纲级别变为三级大纲
End If

Next
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

'* +++++++++++++++++++++++++++++++++++++++
'以"第#"开头的段落，第一句加粗，
'并将该段落升为二级大纲。'
'* ------------------------------------------
Sub 设置大纲4()
Dim pa As Paragraph, MyStr1 As String
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕更新
Call 删除段首空格3 '调用工程
MyStr1 = "一二三四五六七八九十" '假定为手动加注每个段落开头为中文大写数字
For Each pa In ActiveDocument.Paragraphs

  If pa.Range.Characters.First.Text = "第" Then
    If InStr(MyStr1, ActiveDocument.Range(pa.Range.Start + 1, pa.Range.Start + 2).Text) > 0 Then
    pa.Range.Sentences.First.Font.Bold = True '每一段第一句字体加粗
    pa.OutlineLevel = wdOutlineLevel2 '该段落的大纲级别变为二级大纲
    End If
  End If

Next
Application.ScreenUpdating = True '恢复屏幕更新
End Sub

————————————————
原文链接：https://blog.csdn.net/sxycgxj/article/details/6919108/

赏 支付宝打赏 微信打赏

如果文章或资源对您有帮助，欢迎打赏作者。一路走来，感谢有您！