如何从所有打开的Word文档中提取粗体文本实例

Question

Hi以下代码从活动Word文档中提取所有粗体文本实例，并将其复制到新创建的Word文档中。

有人能帮助我调整代码，将所有打开的Word文档执行相同的任务到新创建的Word文档中吗。

非常感谢您的帮助。

Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range
Set ThisDoc = ActiveDocument
Set r = ThisDoc.Range
Set ThatDoc = Documents.Add

With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With
Do While .Find.Execute(Forward:=True) = True
'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop
End With
cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub

Answer 1

您可以使用返回所有打开文档的Documents集合：

Sub A__GrabTheBolds()
On Error GoTo cleanUp
Application.ScreenUpdating = False
Dim ThisDoc As Document
Dim ThatDoc As Document
Dim r As Range

Set ThatDoc = Documents.Add
'iterate over all open word documents
'For Each ThisDoc In Application.Documents
'handle documents in the order they were opened
'reverse order of documents collection
'loop until second to last as last one is ThatDoc

Dim i As Long

Dim FileNames As String, fFound As Boolean
Dim fWritten As Boolean

For i = Application.Documents.Count To 2 Step -1
Set ThisDoc = Application.Documents(i)

'Don't check document where the code runs
If Not ThisDoc Is ThisDocument Then


Set r = ThisDoc.Range

With r
With .Find
.Text = ""
.Format = True
.Font.Bold = True
End With

Do While .Find.Execute(Forward:=True) = True

'<-- remove this part if not needed

'add filename if the first bold range
If fWritten = False Then
ThatDoc.Content.InsertAfter vbCrLf & vbCrLf & ThisDoc.Name & vbCrLf
End If
'remove this part if not needed -->

fWritten = True

'If r.HighlightColorIndex = wdDarkYellow Then 'highlightcols(7)
If r.Bold Then
ThatDoc.Range.Characters.Last.FormattedText = .FormattedText
ThatDoc.Range.InsertParagraphAfter
.Collapse 0
End If
Loop

End With

'add filename to list only if bold has been found
If fWritten = True Then
FileNames = FileNames & vbCrLf & ThisDoc.Name
fWritten = False
End If
End If
Next
'Add list of filenames to the end of ThatDoc
With ThatDoc.Content
.InsertParagraphAfter
.InsertAfter FileNames
End With

cleanUp:
Application.ScreenUpdating = True
Set ThatDoc = Nothing
Set ThisDoc = Nothing
End Sub