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

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 = " 1"
.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，因为它不允许暂停来捕获替换的页码，我已经将您的代码修改为迭代查找/替换。我还将其更改为使用Range vs . Selection，因为它将通过从ReplaceAll到迭代方法来减少一些丢失的速度。最后，我将捕获的Section和页码添加到一个文本文件中，该文件将与文档创建在同一个文件夹中。

查看并根据您的确切需求进行修改。

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 = " 1"
.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 = " 1"
.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