Sub CopyHiglighted()
Application.ScreenUpdating = False
    
Set Sourcedoc = ThisDocument
Set Myrange = ThisDocument.Content
Set newDoc = Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
Sourcedoc.Activate
    With Myrange
        With .Find
            .ClearFormatting
            .Highlight = True
            '.Font.Name = "Times New Roman"
            .Text = ""
            '.Replacement.Text = "\1"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchAllWordForms = False
            .MatchSoundsLike = False
            .MatchWildcards = False
            .Execute
            
            If Not Myrange Is Nothing Then
                Start = Myrange.Start
                Myrange.Copy
                newDoc.Content.InsertAfter vbCrLf
                newDoc.Range(Start:=newDoc.Content.End - 1, _
                    End:=newDoc.Content.End).Paste
                Do
                    .Execute
                    If Myrange Is Nothing Or Myrange.Start = Start Then Exit Do
                    Myrange.Copy
                    newDoc.Content.InsertAfter vbCrLf
                    newDoc.Range(Start:=newDoc.Content.End - 1, _
                        End:=newDoc.Content.End - 1).Paste
                Loop
            End If
        End With
    End With
    newDoc.Content.HighlightColorIndex = wdNoHighlight
    newDoc.Activate
    Application.ScreenUpdating = True
End Sub