Поиск файла по содержимому ячейки

Sub FOR_ALEX()
m = 0
PTH = ThisWorkbook.Path
FN = Dir(PTH & "\*.docx", vbNormal)
ReDim SHName(ThisWorkbook.Sheets.Count)
For i = 1 To ThisWorkbook.Sheets.Count
SHName(i - 1) = Sheets(i).Name
Next
 
ReDim S(m)
      Do
           If FN = "" Then Exit Do
           S(m) = Mid(FN, 1, Len(FN) - 5)
           m = m + 1
           ReDim Preserve S(m)
           FN = Dir()
     Loop
    
 
For i = LBound(S) To UBound(S) - 1
  For j = LBound(SHName) To UBound(SHName)
     If S(i) = SHName(j) Then S(i) = ""
Next
Next
 
For i = i = LBound(S) To UBound(S) - 1
If S(i) <> "" Then Worksheets.Add.Name = S(i)
Next
 
End Sub

Sub primer()
Dim Word As Object
Dim WordDoc As Object
Dim r, f As Boolean, fO As Long
Set Word = CreateObject("Word.Application")
Set WordDoc = Word.Documents.Open(Filename:=Application.ThisWorkbook.path & "\Пример.docx")
 
Set r = WordDoc.Range
Do
With r.Find
    .ClearFormatting
    .Text = "дисциплина *относится"
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = True
    If .Execute Then
                If f Then
                    If r.Start = fO Then
                Exit Do
                    End If
                Else
                    fO = r.Start
                    f = True
                End If
                WordDoc.Range(r.Start + 11, r.End - 9).Copy
                Range("C4").Select
                ActiveSheet.Paste
 
                Set r = WordDoc.Range(r.End, r.End)
            Else
 
                Exit Do
            End If
        End With
    Loop