Sub FindGreenText()
Application.ScreenUpdating = False
Dim oSel As Range
Dim oResponse As Document
Dim oDoc As Document
Dim strDocName As String, strPath As String, strFile As String, strFolder As String

strFolder = "<folder location with doc files>"
strFile = Dir(strFolder & "\*.docx", vbNormal)

Set oDoc = Documents.Open(FileName:=strFolder & " \ " & strFile, AddToRecentFiles:=False, Visible:=True)

While strFile <> ""
    oDoc.Activate 'code stops here with empty set statement
    'DoEvents
    strDocName = Left(oDoc.Name, InStrRev(oDoc.Name, Chr(46)) - 1)
    strDocName = strDocName & "_response.docx"
    strPath = oDoc.Path & Chr(92)
    
    Set sel = ActiveDocument.Range
    Set oResponse = Documents.Add
        With sel.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Text = ""
            .MatchWildcards = False
            .Forward = True
            .Wrap = wdFindStop
            .Font.ColorIndex = wdGreen
            .Execute
            Do Until Not .Found
                If sel.Font.ColorIndex = wdGreen Then
                    sel.Cut
                    With oResponse
                        Selection.Range.Paste
                        Selection.MoveStart unit:=wdParagraph
                        Selection.TypeParagraph
                    End With
                End If
                .Execute
            Loop
        End With
    oDoc.SaveAs2
    oResponse.SaveAs2 strPath & strDocName
    oDoc.Close
    oResponse.Close
    strFile = Dir()
Wend
Application.ScreenUpdating = True
MsgBox "Lucy, I'm home!"
End Sub