Sub CreateSummary()
Application.ScreenUpdating = False
Dim FRDoc As Document, SrcDoc As Document, RsltDoc As Document, FRList, i As Long, Rng As Range
 'Load the strings from the reference doc into a text string to be used as an array.
Set SrcDoc = ActiveDocument
Set FRDoc = Documents.Open("Drive:\FilePath\ReferenceList.doc")
FRList = FRDoc.Range.FormattedText
FRDoc.Close False
Set FRDoc = Nothing
Set RsltDoc = Documents.Add
'Process each string from the reference doc
For i = 0 To UBound(Split(FRList, vbCr)) - 1
  With SrcDoc.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .MatchWholeWord = True
      .MatchCase = True
      .Wrap = wdFindStop
      .Text = Split(FRList, vbCr)(i)
      .Execute
    End With
    Do While .Find.Found
      Set Rng = RsltDoc.Characters.Last
      Rng.Collapse wdCollapseStart
      Rng.FormattedText = .Duplicate.Paragraphs.First.Range.FormattedText
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
  End With
Next
Application.ScreenUpdating = True
End Sub