Sub GatherRoundUpdated()
    Dim aRng As Range, aRngHead As Range, aDoc As Document, aDocNew As Document, aTbl As Table, aRow As Row
    Dim sNum As String, lastPosition As Long
    
    Set aDoc = ActiveDocument
    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"
    
    Set aRng = aDoc.Range
    aRng.Find.ClearFormatting
    aRng.Find.Replacement.ClearFormatting
    aRng.Find.Text = "[Red]"
    aRng.Find.Forward = True
    
    Do While aRng.Find.Execute
        If aRng.Start = lastPosition Then Exit Do ' Exit loop if stuck at the same position
        
        lastPosition = aRng.Start
        
        Set aRngHead = aRng.GoToPrevious(wdGoToHeading)
        If Not aRngHead Is Nothing Then
            aRngHead.End = aRngHead.Paragraphs(1).Range.End - 1
            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
            
            aRow.Cells(1).Range.Text = aRngHead.ListFormat.ListString & vbTab & aRngHead.Text
        End If
        
        aRng.Collapse Direction:=wdCollapseEnd
        aRng.End = aDoc.Range.End
    Loop
    
    ' Clean up
    Set aRng = Nothing
    Set aDoc = Nothing
    Set aDocNew = Nothing
    Set aTbl = Nothing
    Set aRow = Nothing
End Sub