Sub FindGreenText()
       'speed up procedure
Application.ScreenUpdating = False
Dim sel As Range
Dim oResponse As Document
Dim oDoc As Document
Dim strDocName As String, strPath As String, strFile As String, strFolder As String
    'point to location of files
strFolder = "<folder with .docx files>"
strFile = Dir(strFolder & "\*.docx", vbNormal)
    'process each .docx file in folder
While strFile <> ""
    Set oDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)
    oDoc.Activate
    'name the .docx file with a new name for responses
    strDocName = Left(oDoc.Name, InStrRev(oDoc.Name, Chr(46)) - 1)
    strDocName = strDocName & "_response.docx"
    'sets the path to save new .docx file based on location of original .docx file(oDoc)
    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
            'finds green colored text
            .Font.Color = 5287936
            .Execute
            Do Until Not .Found
                If sel.Font.Color = 5287936 Then
                    sel.Cut
                    'pastes green text to new .docx
                    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