Copy Red Text into new document

[Bernadette]

Hello VBA Forum,

I tried recording a macro for the following steps but I got this error "This method or property is not available because no text is selected"
Debug line: Selection.Copy

Steps to copy all red text from document into a new document


Ctrl Home (goes to beginning of document)
Find, Format (bottom left in dialog box), Font
Font Color, Red, OK
Find in, click dropdown and select “Main Document”
Click outside Find and Replace dialog box
Copy (Ctrl C)
New Document (Ctrl N)
Paste (Ctrl V)
Switch back to your document (Alt Tab)
Find in, click dropdown and select “Footnotes”
Click outside Find and Replace dialog box
Copy (Ctrl C)
Switch back to your document (Alt Tab)
Paste (Ctrl V)
Switch back to your document (Alt Tab)
Click “No Formatting” (so that Red Font is no longer in the Find box)
Close (Find and Replace)
Ctrl Home (goes to beginning of document)



Any help is greatly appreciated!

Thanks, Bernie

[macropod]

The simplest way is to delete everything that isn't red, then save what's left as a new document. The following macro does the deletions:

Sub Demo()
Application.ScreenUpdating = False
Dim Rng As Range, Sctn As Section, HdFt As HeaderFooter
With ActiveDocument
For Each Rng In .StoryRanges
Select Case Rng.StoryType
Case wdPrimaryFooterStory, wdFirstPageFooterStory, wdEvenPagesFooterStory, _
wdPrimaryHeaderStory, wdFirstPageHeaderStory, wdEvenPagesHeaderStory
Case Else
Call RangeFndRep(Rng)
End Select
Next
For Each Sctn In .Sections
For Each HdFt In Sctn.Headers
With HdFt
If .LinkToPrevious = False Then
Call RangeFndRep(HdFt.Range)
End If
End With
Next
For Each HdFt In Sctn.Footers
With HdFt
If .LinkToPrevious = False Then
Call RangeFndRep(HdFt.Range)
End If
End With
Next
Next
End With
End Sub
'
Sub RangeFndRep(Rng As Range)
With Rng
.Font.Hidden = True
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Format = True
.Forward = True
.Wrap = wdFindContinue
.MatchWildcards = True
.Font.ColorIndex = wdRed
.Replacement.Font.Hidden = False
.Execute Replace:=wdReplaceAll
.ClearFormatting
.Replacement.ClearFormatting
.Text = "*"
.Font.Hidden = True
.Execute Replace:=wdReplaceAll
End With
End With
End Sub
Note: if your ranges of red content aren't terminated by paragraph breaks that are also formatted red, you're liable to end up with all the content in each range merged together.