Recorded Word Macro, won't run again from Macros 1

[atyrautony]

Baffled, recorded this macro, which achieves the result required. But trying to rerun the macro error of no selection. I think its a brain fade day. Where is the correction needed.
Sub copygreentexttonewdoc()
'
' copygreentexttonewdoc Macro
'
'
Selection.Find.ClearFormatting
Selection.Find.Font.Color = 5287936
With Selection.Find
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Copy
Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
Selection.PasteAndFormat (wdFormatOriginalFormatting)
End Sub

 

[macropod]

You macro will only work if something is selected when you run it. Moreover, what gets copied & pasted to the new document will be whatever your selection is; it has nothing to do with your Find code.

Try:

Sub Demo()
Application.ScreenUpdating = False
Dim DocSrc As Document, DocTgt As Document, i As Long
Set DocSrc = ActiveDocument: Set DocTgt = Documents.Add
With DocSrc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .Font.Color = 5287936
  End With
  Do While .Find.Execute
    i = i + 1
    DocTgt.Range.Characters.Last.FormattedText = .Duplicate.FormattedText
    With DocTgt.Range
      If .Characters.Last.Previous <> vbCr Then .InsertAfter vbCr
    End With
    If .End = ActiveDocument.Range.End Then Exit Do
    .Collapse wdCollapseEnd
  Loop
End With
Application.ScreenUpdating = True
MsgBox i & " instances copied."
End Sub

Cheers
Paul Edstein
[MS MVP - Word]

 

[atyrautony]

Paul, great code but it appears to get looped in
Do While .Find.Execute
i = i + 1
DocTgt.Range.Characters.Last.FormattedText = .Duplicate.FormattedText
With DocTgt.Range
If .Characters.Last.Previous <> vbCr Then .InsertAfter vbCr
End With
If .End = ActiveDocument.Range.End Then Exit Do
.Collapse wdCollapseEnd
Loop

It doesn't do the exit?

I have attached a typical source file

 

[macropod]

Without wanting to over-emphasize it, you didn't say anything about the content being in tables. Before:

    If .End = ActiveDocument.Range.End Then Exit Do

insert:

    If .Information(wdWithInTable) = True Then
      If .End = .Cells(1).Range.End - 1 Then
        .End = .Cells(1).Range.End
        .Collapse wdCollapseEnd
        If .Information(wdAtEndOfRowMarker) = True Then
          .End = .End + 1
        End If
      End If
    End If

Cheers
Paul Edstein
[MS MVP - Word]