Sub SearchInMSWord()
Dim FSO As Object
Dim SourceFolder As Object
Dim FileItem As Object
Dim objWord As Word.Application
Dim wrdDoc As Word.Document
Dim SearchValue As String
Dim s As Variant
Dim elem As Variant
Dim i As Long
Dim n As Long
Dim k As Long
Dim lLastRow As Long

lLastRow = Cells(Rows.Count, 1).End(xlUp).Row

Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.getfolder(ThisWorkbook.Path & "/2017 год")
For Each FileItem In SourceFolder.Files
        k = k + 1
        n = 0
        Set objWord = CreateObject("Word.Application")
        Set wrdDoc = objWord.Documents.Open(FileItem.Path)
        With wrdDoc
                    s = Split(.Range.Text, " ")
                    For Each elem In s
                    For i = 2 To lLastRow
                        SearchValue = Worksheets("Лист1").Cells(i, 1).Value
                            If elem = SearchValue Then
                    n = n + 1
                    Worksheets("Лист1").Cells(n + 1, k + 1).Value = FileItem.Name
                            End If
                    Next
                    Next
        End With
        wrdDoc.Close
        objWord.Quit
Next
End Sub