将宏中所做的任何替换复制到单独的文件作为报告，并附上页码

Question

我目前正在学习如何在 word 中创建宏以查找错误，例如单词之间的空格、句子后的错误，该代码可广泛用于执行此操作，我一直在使用下面的代码来帮助识别任何错误（我有点把几个宏混在一起，它不是完美无缺的，因为它们似乎不能很好地结合在一起，但这不是我的问题。

我正在尝试了解如何在文档末尾的报告中或理想情况下在单独的空白中显示在查找和替换中找到的任何内容的页码，以及要替换的文本片段第一，以某种可读格式，我找不到任何这样的例子，想知道这是否可能？谢谢！


Option Explicit
Sub SpacingFixer()
 'If something goes wrong, go to the errorhandler
    On Error GoTo ERRORHANDLER
    'Current page variable
    CurPage = Selection.Information(wdActiveEndAdjustedPageNumber)
    'Checks the document for excessive spaces between words
    With Selection
        .HomeKey Unit:=wdStory
        With .Find
            .ClearFormatting
            .Replacement.ClearFormatting
            'Here is where it is actually looking for spaces between words
            .Text = " [ ]@([! ])"
            'This line tells it to replace the excessive spaces with one space
            .Replacement.Text = " "
            .MatchWildcards = True
            .Wrap = wdFindStop
            .Format = False
            .Forward = True
            'execute the replace
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Remove white space at the beginning of lines

    With Selection.Find

        .Text = "^p^w"

        .Replacement.Text = "^p"

    End With

Selection.Find.Execute Replace:=wdReplaceAll

' Removes spaces in first line

    With Selection.Find

        .Text = " {3,}"

        .Replacement.Text = ""

    End With

Selection.Find.Execute Replace:=wdReplaceAll
         
        With .Find
            'This time its looking for excessive spaces after a paragraph mark
            .Text = "^p "
            'What to replace it with
            .Replacement.Text = "^p"
            .MatchWildcards = False
            .Wrap = wdFindStop
            .Format = False
            .Forward = True
            'Execute the replace
            .Execute Replace:=wdReplaceAll
        End With
    End With
ERRORHANDLER:
    With Selection
        .ExtendMode = False
        .HomeKey Unit:=wdStory
    End With

End Sub

Answer 1

您不能使用 ReplaceAll，因为它不允许暂停以捕获替换的页码，我已将您的代码修改为迭代 Find/Replace。我还将其更改为使用 Range 与 Selection，因为它将通过从 ReplaceAll 转到迭代方法来减少一些损失的速度。最后，我将章节和页码的捕获添加到一个文本文件中，该文件将在与文档相同的文件夹中创建。

查看并根据您的具体需要进行修改。

Sub SpacingFixer()
    Dim doc As Word.Document, rng As Word.Range
    Dim FileNum As Integer
    Dim oFile As String
    
    On Error GoTo ERRORHANDLER
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    FileNum = FreeFile()
    oFile = doc.path & "\AuthorTec_Edits.txt"
    If Dir(oFile, vbNormal) <> vbNullString Then
        Kill oFile
    End If
    Open oFile For Append As #FileNum
    Print #FileNum, "Extra spaces between words on Section:Page:"
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        'Here is where it is actually looking for spaces between words
        .Text = " [ ]@([! ])"
        'This line tells it to replace the excessive spaces with one space
        .Replacement.Text = " "
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        'execute the replace
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
        
        ' Remove white space at the beginning of lines
    Print #FileNum, "Extra white space at beginning of lines on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = "^p^w"
        .Replacement.Text = "^p"
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

' Removes spaces in first line
    Print #FileNum, "Removed spaces in first line on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = " {3,}"
        .Replacement.Text = ""
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

    Print #FileNum, "Removed excessive spaces after a paragraph mark on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        'This time its looking for excessive spaces after a paragraph mark
        .Text = "^p "
        'What to replace it with
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
ERRORHANDLER:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCr & Err.Description, vbCritical
        Err.Clear
    Else
        MsgBox "Action Complete"
    End If
    If FileNum <> 0 Then Close #FileNum

End Sub

Answer 2

添加了检测以句号结尾的项目符号 1 和 2 样式并将它们打印到文本文件的选项。

还发现，如果你创建了一个无限循环，那是因为 .Wrap 需要 = wdFindStop

.Wrap = wdFindStop


Sub Spacingandbulletfixerwithreport()
    Dim doc As Word.Document, rng As Word.Range
    Dim FileNum As Integer
    Dim oFile As String
    
    On Error GoTo ERRORHANDLER
    Set doc = ActiveDocument
    Set rng = doc.Content
    
    FileNum = FreeFile()
    oFile = doc.Path & "\AuthorTec_Edits.txt"
    If Dir(oFile, vbNormal) <> vbNullString Then
        Kill oFile
    End If
    Open oFile For Append As #FileNum
    Print #FileNum, "Extra spaces between words on Section:Page:"
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        'Here is where it is actually looking for spaces between words
        .Text = " [ ]@([! ])"
        'This line tells it to replace the excessive spaces with one space
        .Replacement.Text = " "
        .MatchWildcards = True
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        'execute the replace
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
        
        ' Remove white space at the beginning of lines
    Print #FileNum, "Extra white space at beginning of lines on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = "^p^w"
        .Replacement.Text = "^p"
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

' Removes spaces in first line
    Print #FileNum, "Removed spaces in first line on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .Text = " {3,}"
        .Replacement.Text = ""
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With

    Print #FileNum, "Removed excessive spaces after a paragraph mark on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        'This time its looking for excessive spaces after a paragraph mark
        .Text = "^p "
        'What to replace it with
        .Replacement.Text = "^p"
        .MatchWildcards = False
        .Wrap = wdFindStop
        .Format = False
        .Forward = True
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
    
    'search for bullet1s with full stops
    Print #FileNum, "Removed Bullet 1s on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Bullet 1")
        .Replacement.ClearFormatting
        .Text = ".^p"
        .Replacement.Text = ".^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
           Wend
        End With
           
               'search for bullet2s with full stops
    Print #FileNum, "Removed Bullet 2s on Section:Page:"
    Set rng = doc.Content
    With rng.Find
        .ClearFormatting
        .Style = ActiveDocument.Styles("Bullet 2")
        .Replacement.ClearFormatting
        .Text = ".^p"
        .Replacement.Text = ".^p"
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        While .Execute
           Print #FileNum, rng.Information(wdActiveEndSectionNumber) & ":" & rng.Information(wdActiveEndAdjustedPageNumber)
           rng.Collapse Word.WdCollapseDirection.wdCollapseEnd
        Wend
    End With
    
    

ERRORHANDLER:
    If Err.Number <> 0 Then
        MsgBox Err.Number & vbCr & Err.Description, vbCritical
        Err.Clear
    Else
        MsgBox "Action Complete"
    End If
    If FileNum <> 0 Then Close #FileNum

End Sub

将宏中所做的任何替换复制到单独的文件作为报告，并附上页码

Copy any replacements made in a macro to a separate file as a report, with page number

vba

ms-word