Option Explicit

Sub zelenitsa()
Dim i As Byte
Dim inipos As Long
Dim strPath As String
Dim appExl As Excel.Workbook
Dim xlsSht As Excel.Worksheet
Dim appWrd As Word.Application
Dim docWrd As Word.Document
Dim docRng As Word.Range

Const shtName As String = "List1"
'Const dostup As String = "C:\Temp\" 'Vtoroy variant

    i = 2
    strPath = ThisWorkbook.Path & "\" & Trim(Range("b5").Value) & ".doc" '"F2.doc"
    'ili
    'Vtoroy variant
    'strPath = dostup & Trim(Range("b5").Value) & ".doc" '"F2.doc"
    
    Set appExl = ThisWorkbook
    Set xlsSht = appExl.Sheets(shtName)
    Set appWrd = New Word.Application
    Set docWrd = appWrd.Documents.Open(Filename:=strPath, ReadOnly:=True)
    Set docRng = docWrd.Range
    'appWrd.Visible = True 'Tol'ko dlya testov
    
    With docRng.Find
        .Highlight = True
        .Forward = True
        
        Do While .Execute
            If docRng.HighlightColorIndex = wdBrightGreen Then
                xlsSht.Range("b" & xlsSht.Rows.Count).End(xlUp).Offset(i, 0).Value = docRng.Text
                If i = 2 Then i = 1
            End If
            inipos = docRng.End
            docRng.Start = inipos
        Loop
    End With
    
    Set docRng = Nothing
    docWrd.Close SaveChanges:=wdDoNotSaveChanges
    Set docWrd = Nothing
    appWrd.Quit
    Set appWrd = Nothing
    Set xlsSht = Nothing
    Set appExl = Nothing
End Sub

Option Explicit

Sub nayti_dokument()
Dim stlb As Integer
Dim dostup As String, docDokument As String

    Application.ScreenUpdating = False
    
    stlb = 0
    dostup = ThisWorkbook.Path & "\"
    docDokument = Dir(dostup & "F*.doc", vbNormal) 'vse dokumenty na "F", ili naprimer "*.doc" - vse dokumenty
    
    Do Until docDokument = ""
        stlb = stlb + 1
        Call zelenitsa(dostup, docDokument, stlb)
        docDokument = Dir()
    Loop
    
    Application.ScreenUpdating = True
End Sub

Sub zelenitsa(dostup As String, docDokument As String, stlb As Integer)
Dim i As Byte
Dim inipos As Long
Dim appExl As Excel.Workbook
Dim xlsSht As Excel.Worksheet
Dim appWrd As Word.Application
Dim docWrd As Word.Document
Dim docRng As Word.Range

Const shtName As String = "List1"

    i = 2
    
    Set appExl = ThisWorkbook
    Set xlsSht = appExl.Sheets(shtName)
    Set appWrd = New Word.Application
    Set docWrd = appWrd.Documents.Open(Filename:=dostup & docDokument, ReadOnly:=True)
    Set docRng = docWrd.Range
    'appWrd.Visible = True 'Tol'ko dlya testov
    
    xlsSht.Cells(5, stlb).Value = Left(docDokument, InStrRev(docDokument, ".", -1, 1) - 1)
    
    With docRng.Find
        .Highlight = True
        .Forward = True
        
        Do While .Execute
            If docRng.HighlightColorIndex = wdBrightGreen Then
                xlsSht.Cells(xlsSht.Rows.Count, stlb).End(xlUp).Offset(i, 0).Value = docRng.Text
                If i = 2 Then i = 1
            End If
            inipos = docRng.End
            docRng.Start = inipos
        Loop
    End With
    
    Set docRng = Nothing
    docWrd.Close SaveChanges:=wdDoNotSaveChanges
    Set docWrd = Nothing
    appWrd.Quit
    Set appWrd = Nothing
    Set xlsSht = Nothing
    Set appExl = Nothing
End Sub

'Dim appWrd As Word.Application
Dim appWrd As New Word.Application

    'Set appWrd = New Word.Application

Dim appWrd As Object
Dim docWrd As Object
Dim docRng As Object

    Set appWrd = CreateObject("Word.Application")