Sub GatherRound()
  Dim aRng As Range, aRngHead As Range, aDoc As Document, aDocNew As Document, aTbl As Table, aRow As Row
  Dim sNum As String
  Set aDoc = ActiveDocument
  Set aRng = aDoc.Range
  Set aDocNew = Documents.Add
  Set aTbl = aDocNew.Tables.Add(aDocNew.Range, 1, 2)
  aTbl.Cell(1, 1).Range.Text = "Heading"
  aTbl.Cell(1, 2).Range.Text = "Text"
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[Red]"
    .Forward = True
    Do While .Execute
      aRng.Start = aRng.Paragraphs(1).Range.Start
      Set aRow = aTbl.Rows.Add
      If aRng.ListFormat.ListType = wdListNoNumbering Then
        aRow.Cells(2).Range.FormattedText = aRng.FormattedText
      Else
        sNum = aRng.ListFormat.ListString
        aRow.Cells(2).Range.Text = sNum & vbTab & aRng.Text
      End If
      Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
      aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
      aRow.Cells(1).Range.Text = aRngHead.ListFormat.ListString & vbTab & aRngHead.Text
      aRng.Collapse Direction:=wdCollapseEnd
      aRng.End = aDoc.Range.End
    Loop
  End With
End Sub