Sub FindYellowText()

Dim oSel As range
Dim oResponse As Document

    Set sel = ActiveDocument.range
    Set oResponse = Documents.Add
    
    With sel.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = ""
        .MatchWildcards = False
        .Forward = True
        .Wrap = wdFindStop
        .Font.ColorIndex = wdYellow
        .Execute
        Do Until Not .found
            If sel.Font.ColorIndex = wdYellow Then
                sel.Cut
                With oResponse
                    selection.range.Paste
                    selection.MoveStart unit:=wdParagraph
                    selection.TypeParagraph
                End With
            End If
            .Execute
        Loop
    End With
End Sub