Option Explicit
const wdFormatDocument = 0
Const msoFileTypeWordDocuments = 3
Const wdDoNotSaveChanges = 0
Const wdAlertsNone = 0

Dim objWord, objFSO, strPathToCopy, i, fso, UFolder, UFile, f1, filename, k ,WordsArray, CreateFolder, n

Set objWord = CreateObject("Word.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
    FileName = "файл.doc"
    strPathToCopy = "C:\Out\"
    WordsArray=Array("текст","")
    objWord.DisplayAlerts = wdAlertsNone

    With objWord.FileSearch
        .NewSearch
    .LookIn = "C:\in\"
    .SearchSubFolders = True
    .FileName = "*.doc"
        For k=0 To UBound(WordsArray) - 1 
            .TextOrProperty = WordsArray(k)
                    If .Execute > 0 Then                    
                For i = 1 To .FoundFiles.Count
                                    If Not objFSO.FileExists(strPathToCopy+FileName) then
                                objFSO.MoveFile .FoundFiles(i), strPathToCopy+FileName
                    Else
                        n=n+1
                         objFSO.MoveFile .FoundFiles(i), strPathToCopy & n & FileName
                    end if
                Next
            End If
        Next
    End With
Set objFSO = Nothing
objWord.Quit wdDoNotSaveChanges