Sub GetRedData()
'Note: this code requires a reference to the Word object model.
'See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim WkSht1 As Worksheet, WkSht2 As Worksheet, r As Long, x As Long
Set WkSht1 = ThisWorkbook.Sheets("Act"): Set WkSht2 = ThisWorkbook.Sheets("Results")
Dim wdApp As New Word.Application, wdDoc As Word.Document
With wdApp
  .Visible = False
  Set wdDoc = .Documents.Add: WkSht1.UsedRange.Copy
  With wdDoc
    With .Range
      .PasteExcelTable False, False, False
      With .Find
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .Font.Color = 3618778
      End With
      Do While .Find.Execute
        r = .Cells(1).RowIndex: x = x + 1
        With WkSht2
          .Range("B" & x).Value = x: .Range("C" & x).Value = r
          .Range("D" & x).Value = WkSht1.Range("A" & r).Value
          WkSht1.Range("B" & r).Copy
          .Paste Destination:=.Range("F" & x)
        End With
        .Start = .Cells(1).Range.End + 1
      Loop
      
    End With
    .Close SaveChanges:=False
  End With
  .Quit
End With
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht1 = Nothing: Set WkSht2 = Nothing
Application.ScreenUpdating = True
End Sub