优化整理文档代码

chenwenming

目的：网校讲义下载合并后，添加标题大纲
功能如下：1、去除文档中各处插入的卖课件人的推销图片
                  2、替换文档中全角空格为半角空格
                  3、设置一、二、三级标题大纳格式
                  4、去除重复的标题大纳
求助1、优化代码；2、解决三级标题前面是表格不能设置的问题
Sub 整理课程标题()
Dim i As Integer '循环执行
Dim myRange As Range
Dim oInlineShape As InlineShape, oShape As Shape
Dim myHeight As Single, myWidth As Single
Dim acon As New Collection
Dim apar As Paragraph
Dim starttime, endtime
On Error Resume Next
starttime = Timer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'删除指定图片
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    myHeight = 23    '磅,必须以磅为单位,如以厘米等,则会在单位换算过程中出现误差
    myWidth = 415    '磅
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '如 以磅为单位返回需要删除的图形的宽或者高
    '    MsgBox Selection.ShapeRange(1).Width
    '    MsgBox Selection.ShapeRange(1).Height
    '    MsgBox Selection.InlineShapes(1).Width
    '    MsgBox Selection.InlineShapes(1).Height
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = False
    '删除指定高度宽度的嵌入式图形
    For Each oInlineShape In ActiveDocument.InlineShapes
        If oInlineShape.Height = myHeight And oInlineShape.Width = myWidth Then oInlineShape.Delete
    Next
    '删除指定宽度高度的浮动式图形
    For Each oShape In ActiveDocument.Shapes
        If oShape.Height = myHeight And oShape.Width = myWidth Then oShape.Delete
    Next

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'替换全角空格为半角空格
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Selection.Type = wdSelectionIP Then Selection.WholeStory
    Set myRange = Selection.Range
    myRange.Find.Execute FindText:="　", replacewith:="  ", Replace:=wdReplaceAll    '替换所有全角空格为半角空格
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'设置标题
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To 100 '假设有100个，循环执行100次 ，设置一级标题
    ' 查找一二三顿号开头的段落
    Selection.Find.ClearFormatting '清除查找框格式
    Selection.Find.Replacement.ClearFormatting  '清除替换框格式
    With Selection.Find
        .Text = "(第[一二三四五六七八九十]{1,}章 )(*^13)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute ' 设置字体字号 Macro
    Selection.Font.Name = "仿宋" '字体
    Selection.Font.Bold = True '加粗
    Selection.Font.Size = 16 '字号，14=四号；16=三号……
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '居中对齐
    Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel1   '设为标题1
Next i
For i = 1 To 100 '假设有100个，循环执行100次 标题二设置
    ' 查找一二三顿号开头的段落
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(第[一二三四五六七八九十]{1,}节 )(*^13)"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute ' 设置字体字号 Macro
    Selection.Font.Name = "等线（中文正文）" '字体
    Selection.Font.Bold = True '加粗
    Selection.Font.Size = 12 '字号，14=四号；16=三号……
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '居中对齐
    Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel2   '设为标题1
Next i
For i = 1 To 500 '假设有100个，循环执行100次 标题三设置
    ' 查找一二三顿号开头的段落
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(^13[一二三四五六七八九十]{1,}、)(*^13)" '未能解决标题前是表格的，就设置不了，求解决？
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute ' 设置字体字号 Macro
    Selection.MoveStart Unit:=wdCharacter, Count:=1
    Selection.Paragraphs(1).Range.Select
    Selection.Font.Name = "等线（中文正文）" '字体
    Selection.Font.Bold = True '加粗
    Selection.Font.Size = 10.5 '字号，14=四号；16=三号……
    Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft  '居中对齐
    Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel3  '设为标题1
Next i
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'删除重复标题
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For Each apar In ActiveDocument.Paragraphs
   acon.Add apar.Range, VBA.CStr(apar.Range.Text)
   If Err.Number = 457 Then
        apar.Range.Delete   '直接删除重复段落
        'apar.Range.Font.Color = wdColorRed  '标记重复段落为红色
        Err.Clear
        End If
Next
Application.ScreenUpdating = True
endtime = Timer
MsgBox "用时：  " & endtime - startime
End Sub

chenwenming

各大版主、能手、高阶，能指点一二吗？

chenwenming

自己优化了一个

Sub 整理课程标题()
Dim i As Integer '循环执行
Dim myRange As Range
Dim oInlineShape As InlineShape, oShape As Shape
Dim myHeight As Single, myWidth As Single
Dim acon As New Collection
Dim apar As Paragraph
Dim starttime, endtime
Dim MyStr As String, YouStr As String
On Error Resume Next
starttime = Timer
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'删除指定图片
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    myHeight = 23    '磅,必须以磅为单位,如以厘米等,则会在单位换算过程中出现误差
    myWidth = 415    '磅
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '如 以磅为单位返回需要删除的图形的宽或者高
    '    MsgBox Selection.ShapeRange(1).Width
    '    MsgBox Selection.ShapeRange(1).Height
    '    MsgBox Selection.InlineShapes(1).Width
    '    MsgBox Selection.InlineShapes(1).Height
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Application.ScreenUpdating = False
    '删除指定高度宽度的嵌入式图形
    For Each oInlineShape In ActiveDocument.InlineShapes
        If oInlineShape.Height = myHeight And oInlineShape.Width = myWidth Then oInlineShape.Delete
    Next
    '删除指定宽度高度的浮动式图形
    For Each oShape In ActiveDocument.Shapes
        If oShape.Height = myHeight And oShape.Width = myWidth Then oShape.Delete
    Next

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'替换全角空格为半角空格
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If Selection.Type = wdSelectionIP Then Selection.WholeStory
    Set myRange = Selection.Range
    myRange.Find.Execute FindText:="　", replacewith:="  ", Replace:=wdReplaceAll    '替换所有全角空格为半角空格
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'设置标题
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
MyStr = "第"
YouStr = "一二三四五六七八九十"
With ActiveDocument
    For Each apar In .Paragraphs
      If apar.Range.Information(wdWithInTable) = False Then
           If apar.Range.Find.Execute(FindText:="第[一二三四五六七八九十]{1,}章 ", Forward:=True, MatchWildcards:=True) = True And InStr(MyStr, ActiveDocument.Range(apar.Range.Start, apar.Range.Start + 1).Text) > 0 Then
             '.Style = wdStyleHeading3
             With apar.Range
             .Font.Name = "仿宋" '字体
             .Font.Bold = True '加粗
             .Font.Size = 16 '字号，14=四号；16=三号……
             .ParagraphFormat.Alignment = wdAlignParagraphCenter  '居中对齐
             .ParagraphFormat.OutlineLevel = wdOutlineLevel1   '设为标题1
             End With
             ElseIf apar.Range.Find.Execute(FindText:="第[一二三四五六七八九十]{1,}节 ", Forward:=True, MatchWildcards:=True) = True And InStr(MyStr, ActiveDocument.Range(apar.Range.Start, apar.Range.Start + 1).Text) > 0 Then
             With apar.Range
             .Font.Name = "等线（中文正文）" '字体
             .Font.Bold = True '加粗
             .Font.Size = 12 '字号，14=四号；16=三号……
             .ParagraphFormat.Alignment = wdAlignParagraphCenter  '居中对齐
             .ParagraphFormat.OutlineLevel = wdOutlineLevel2   '设为标题1
             End With
             ElseIf apar.Range.Find.Execute(FindText:="[一二三四五六七八九十]{1,}、", Forward:=True, MatchWildcards:=True) = True And InStr(YouStr, ActiveDocument.Range(apar.Range.Start, apar.Range.Start + 1).Text) > 0 Then
             With apar.Range
             .Font.Name = "等线（中文正文）" '字体
             .Font.Bold = True '加粗
             .Font.Size = 10.5 '字号，14=四号；16=三号……
             .ParagraphFormat.Alignment = wdAlignParagraphLeft  '居中对齐
             .ParagraphFormat.OutlineLevel = wdOutlineLevel3  '设为标题1
              End With
             End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'删除重复标题
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   acon.Add apar.Range, VBA.CStr(apar.Range.Text)
   If Err.Number = 457 Then
        apar.Range.Delete   '直接删除重复段落
        'apar.Range.Font.Color = wdColorRed  '标记重复段落为红色
        Err.Clear
        End If

   End If
    Next
End With


Application.ScreenUpdating = True
endtime = Timer
MsgBox "用时：  " & endtime - startime
End Sub

chenwenming

还是有BUG,主要原因是重复段落的删除不对，一个章节中的重复段落才删除，非一个章节重复不删除，这代码将所有章节重复段落删除了，我的去，我得想办法将章节标题合并后才删除才不错删除。怎么弄啊，找资料去。。。。。。

iamadsl

关于优化，我觉得使用For循环的效率比较低，因为你不知道到底有多少个，for 100可能只用到十几个，可以改成do while true

关于三级标题那个，我也有类似的问题，主要是通配符没法定位段首，而段落上有表格的话，又没法用^13，解决的思路是使用正则，但WD正则我也不会。。。楼主可以如果会这方面，可以试一下，有解决的方法也告诉我一下哈~

chenwenming

iamadsl 发表于 2017-11-13 11:43
关于优化，我觉得使用For循环的效率比较低，因为你不知道到底有多少个，for 100可能只用到十几个，可以改成 ...

找到个正则大师，没学会；大师脾气较大；找江科大的垄老师，给写了个网页语言的，也没搞懂。

413191246se

* 楼主，你好！——我有 Word 自动排版宏，建议试用（重复的大纲标题，可以全部设置为标题样式后，用“文档结构图”来观察删除）。
* 另外，建议 楼主 能否提供一个附件，说明要求，就像大家不愿意看我的代码一样，我也不愿意看你的代码，嫌多，不如重新编码。


* 排版分两种：一是纯文本（无表格），直接全选再设置正文、标题即可；二是有表格文档，过去我是不管有无表格一律当成无表格来排版，清除格式；但现在，一般情况是别人已经编辑好的表格，所以不宜再清除格式了，费那个时间也没有必要，所以新理念就是：有表格文档排版时，最快的方法就是，首先让表格无环绕，然后，分别取表格间的区域 Range 进行区域（块状）排版（无表格文本实际上就是最大的区域/块状），这样速度极快（但超大文本排版还有问题，我觉得是 Word 不断分页的原因，会含有很多“节”）。像“第X章/第X节”这样的标题，我已经有宏，一键即可自动设置格式。

* 比如：选定从文首到第一个表格间的区域，即 ActiveDocument.Range(Start:=0,End:=.Tables(1).Range.Start).Select


* 既然是区域排版，区域上面有表格，只须将区域前面加一个回车即可，即 If .Start <> 0 Then .InsertParagraphBefore

chenwenming

413191246se 发表于 2019-8-1 20:26
* 楼主，你好！——我有 Word 自动排版宏，建议试用（重复的大纲标题，可以全部设置为标题样式后，用“文档 ...

可否提供宏代码我试试

413191246se

请参见：http://club.excelhome.net/thread-1487647-1-1.html

chenwenming

谢谢，学习了