这段代码如何优化

zzpsx

本人经常要从网上下载文章，复制到word文档中，要执行批量删除空行，插入页码，首行缩进，插入表格，把文章放进左半个表格中，使用了以下代码，但很卡，不知道如何优化？ 想要的效果.rar (18.29 KB, 下载次数: 4)

2018-11-30 20:37 上传

点击文件名下载附件

最终需要这样的效果
Sub 排版()
    Dim i As Paragraph, n As Integer
    Application.ScreenUpdating = False
    Rem 删除空行
    For Each i In ActiveDocument.Paragraphs
        If Len(i.Range) = 1 Then
            i.Range.Delete
            n = n + 1
        End If
    Next
    Rem 加一行
    Set oRng = ActiveDocument.Range(0, 0)
    oRng.Text = Chr(13)
    oRng.ParagraphFormat.Alignment = wdAlignParagraphCenter
    oRng.Collapse 0
    Rem 插入表格
    ActiveDocument.Tables.Add Range:=oRng, NumRows:=1, NumColumns:=2, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
    With ActiveDocument.Tables(1)
        If .Style <> "网格型" Then .Style = "网格型"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = True
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = True
    End With
    Set oRng = ActiveDocument.Content
    ActiveDocument.Tables(1).Cell(1, 1).Range = oRng.Text
    For Each oP In ActiveDocument.Tables(1).Cell(1, 1).Range.Paragraphs
        If oP.Range = Chr(13) Then oP.Range.Delete
    Next
    For Each oP In ActiveDocument.Paragraphs
        If oP.Range.Information(wdWithInTable) = False Then
            oP.Range.Delete
        End If
    Next
    Rem 首行缩进
    With ActiveDocument.Content.ParagraphFormat
        .CharacterUnitFirstLineIndent = 2
        .LeftIndent = 0
    End With
    Rem 增加页码
   With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary)
        Set rng = .Range
        rng.Text = Empty
        rng.Text = "第 "
        rng.Collapse wdCollapseEnd
        ActiveDocument.Fields.Add rng, wdFieldPage
        rng.Select
        Set rng = .Range
        rng.Collapse wdCollapseEnd
        rng.Text = " 页 共 "
        rng.Collapse wdCollapseEnd
        ActiveDocument.Fields.Add rng, wdFieldNumPages, "Pages"
        Set rng = .Range
        rng.Collapse wdCollapseEnd
        rng.Text = " 页"
        rng.Fields.Update
        rng.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
    Application.ScreenUpdating = True
End Sub

413191246se

1. Sub 网友排版Word2003VBA()
   
2.     With ActiveDocument
   
3.         With .Content
   
4.             With .Find
   
5.                 .Execute "^13", , , , , , , , , "`", 2
   
6.                 .Execute "^11", , , , , , , , , "`", 2
   
7.                 .Execute "```", , , , , , , , , "`", 2
   
8.                 .Execute "``", , , , , , , , , "`", 2
   
9.             End With
   
10.             .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
    
11.         End With
    
12.         Selection.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=False
    
13.         Selection.ParagraphFormat.CharacterUnitFirstLineIndent = 2
    
14.         .Content.Find.Execute "`", , , , , , , , , "^p", 2
    
15.         .Tables(1).Range.Cells(1).Range.Characters.Last.Previous.Delete
    
16.         .Tables(1).Style = "网格型"
    
17.     End With
    
18.     ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
    
19.     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    
20.     NormalTemplate.AutoTextEntries("第 X 页 共 Y 页").Insert Where:=Selection.Range, RichText:=True
    
21.     ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    
22. End Sub

复制代码

zzpsx

413191246se 发表于 2018-12-1 19:53

谢谢，太厉害了，您的代码非常流畅。表格顶上可否加一空行，我用来写标题。

413191246se

按 Ctrl + Home 组合键将光标定位于文首，然后打回车键。