CODEWITHSUNDEEP
vbams-word
Mikee S
Mikee S

Reputation: 47

How do I extract instances of Bold text from all open Word documents

Hi the following code extracts all instances of bold text from the active Word document and copies it to a newly created Word document.

Can anyone please help me to adjust the code to perform the same task on all open Word documents into the newly created Word document.

Any help is very much appreciated.

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

Upvotes: 0

Views: 678

Answers (1)

Ike
Ike

Reputation: 13064

You can use the Documents-collection which returns all open 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

Upvotes: 1

Related Questions