Sub OpenOnlyWord()
    Dim FSO As Object
    Dim SourceFolder As Object
    Dim FileItem As Object
    Dim objWord As Object
    Dim wrdDoc As Object
    Dim myRange As Object
    Dim flag As Boolean
    Dim sFolder As String, sFile As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    
    Set SourceFolder = FSO.getfolder(sFolder)
    Set objWord = CreateObject("Word.Application")
    flag = False
    sFile = ThisWorkbook.Sheets(1).Range("E2").Value 'например "У-222"
  
'поочередное открытие файлов .doc, .docx и .docm, содержащих в имени sFile:
      'FileItem = Dir(sFolder & "*" & sFile & "*.doc*") 'не прокатило :-(
      For Each FileItem In SourceFolder.Files
        Set wrdDoc = objWord.Documents.Open(FileItem.Path, , True)
        ThisWorkbook.Sheets(1).Range("B2") = wrdDoc.Bookmarks("код").Range.Text
        wrdDoc.Close
          If ThisWorkbook.Sheets(1).Range("D2") = 1 Then
            MsgBox "код найден"
            GoTo letQuit
          End If
      Next
'поочередное открытие всех файлов .doc, .docx и .docm:
      'FileItem = Dir(sFolder & "*.doc*") 'не прокатило :-(
      For Each FileItem In SourceFolder.Files
        Set wrdDoc = objWord.Documents.Open(FileItem.Path, , True)
        ThisWorkbook.Sheets(1).Range("B2") = wrdDoc.Bookmarks("код").Range.Text
        wrdDoc.Close
          If ThisWorkbook.Sheets(1).Range("D2") = 1 Then
            MsgBox "код найден"
            GoTo letQuit
          End If
      Next
    MsgBox "код НЕ найден"
letQuit:
    objWord.Quit
    Set wrdDoc = Nothing: Set objWord = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub