Word 2007 - 宏来清理文本

时间：2013-01-28 03:24:06

标签： vba text ms-word

我正在尝试编写一个格式化文本的宏。

这是原始数据的样子：

  This is sentence one of paragraph one. This is 
     sentence two of paragraph one. This is 
    sentence three of paragraph one. This is sentence 
    four of paragraph one. This is sentence five of 
    paragraph one.

  This is sentence one of paragraph two. This is 
    sentence two of paragraph two. This is 
      sentence three of paragraph two. This is sentence 
      four of paragraph two. This is sentence five of 
   paragraph two.

这就是我想要的文字：

This is sentence one of paragraph one. This is sentence two of paragraph one. This is  
sentence three of paragraph one. This is sentence four of paragraph one. This is 
sentence five of paragraph one.

This is sentence one of paragraph two. This is sentence two of paragraph two. This is  
sentence three of paragraph two. This is sentence four of paragraph two. This is 
sentence five of paragraph two.

此宏将确保文本填满整个页面，每个单词之间只有一个空格。它需要保留段落结构。

我从Excel调用此宏并从Word运行可读性统计信息。

这是我到目前为止的代码：

Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function EmptyClipboard Lib "user32" () As Long
Public Declare Function CloseClipboard Lib "user32" () As Long

Sub Test_Button1()

    Dim file As String
    Dim StatText As String
    Dim rs As Variant
    Dim row_count As Integer
    Dim header_count As Integer

    row_count = 0
    header_count = 0

    Sheets("Sheet1").Select
    Range("B5").Select

    Set appWD = New Word.Application
    appWD.Visible = True

    Do Until IsEmpty(ActiveCell)
        row_count = row_count + 1
        OpenClipboard (0&)
        EmptyClipboard
        CloseClipboard
        ActiveCell.Copy
        appWD.Documents.Add
        appWD.Selection.PasteSpecial Link:=False, DataType:=wdPasteText, Placement:=wdInLine, DisplayAsIcon:=False
        appWD.ActiveDocument.Select
        With appWD.Selection.ParagraphFormat
            .SpaceBefore = 0
            .SpaceAfter = 0
            .LineSpacingRule = wdLineSpaceSingle
            .WidowControl = False
            .KeepWithNext = False
            .KeepTogether = False
            .PageBreakBefore = False
        End With

        If row_count = 1 Then
           ActiveCell.Offset(-1, 0).Select
           For Each rs In appWD.ActiveDocument.readabilitystatistics
               header_count = header_count + 1
               ActiveCell.Offset(0, 1).Select
               ActiveCell.Value = rs.Name
           Next rs
           ActiveCell.Offset(1, -header_count).Select
        End If

        For Each rs In appWD.ActiveDocument.readabilitystatistics
            ActiveCell.Offset(0, 1).Select
            ActiveCell.Value = rs.Value
            StatText = StatText & rs.Name & " - " & rs.Value & vbCr
        Next rs

        appWD.ActiveDocument.Select
        appWD.Selection.Delete
        appWD.ActiveWindow.Close SaveChanges:=wdDoNotSaveChanges
        ActiveCell.Offset(1, -header_count).Select
    Loop

    appWD.Quit SaveChanges:=wdDoNotSaveChanges    
    Set appWD = Nothing    
End Sub

3 个答案:

答案 0 :(得分：2)

  1. 使用随机字符串（例如“0PbEGMySxe3Bz4NOXUcw”）运行搜索和替换替换双换行符，该字符串不会出现在文档中的任何其他位置。
  2. 运行搜索和替换，替换所有剩余的换行符
  3. 用一个空格替换多个空格（根据需要重复）。
  4. 根据需要用步骤/换行符替换步骤1中的随机字符串。

    5. 如果您不想以编程方式查找如何进行搜索和替换，可以使用内置宏录制器录制这些操作，然后根据您的程序调整代码。

    结果是：

    Sub test()
'
' test Makro
'
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "\n\n"
        .Replacement.Text = "asdfasdfasdf"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "\n"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    With Selection.Find
        .Text = "  "
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "asdfasdfasdf"
        .Replacement.Text = "^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

    你显然想要在使用之前清理它，并重复空白搜索和替换，直到没有任何东西（例如只运行10次，它是指数级的，这就足够了）。

答案 1 :(得分：0)

您可以尝试这样的事情：

Sub CleanWordDocument()

    Dim objWord As Word.Application, objDoc As Word.Document, c As Word.Range

    Set objWord = New Word.Application
    objWord.Visible = True
    Set objDoc = objWord.Documents.Open("C:\Users\user\Documents\test1.docx")

    Set c = objWord.ActiveDocument.Content
    c.ParagraphFormat.Alignment = wdAlignParagraphJustify

    With c.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Text = "  "
        .Replacement.Text = " "
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

        .Execute Replace:=wdReplaceAll
        While .Found
            .Execute Replace:=wdReplaceAll
        Wend
    End With

    objDoc.Save
    objWord.Quit wdDoNotSaveChanges
    Set objWord = Nothing
End Sub

答案 2 :(得分：0)

Sub Macro1（）

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "^p "
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute
Do While Selection.Find.Found
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute

Loop
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
Selection.Find.Replacement.Font.Underline = wdUnderlineSingle
With Selection.Find
    .Text = "^p^p"
    .Replacement.Text = "^&"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Font.Underline = wdUnderlineNone
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "^p"
    .Replacement.Text = " "
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "^p^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
 Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "  "
    .Replacement.Text = " "
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
End With
Selection.Find.Execute
Do While Selection.Find.Found
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.Execute

Loop

End Sub

相关问题
最新问题