Word Recherche d'une occurrence dans un répertoire de fichiers Word.

Sub Rechercher()
Dim chemin$, doc$, P As Range, Wapp As Object, i&
chemin = ThisWorkbook.Path & "\" 'à adapter
doc = Dir(chemin & "*.doc*") '1er document du dossier
Application.ScreenUpdating = False
[B2].Resize(Rows.Count - 1, Columns.Count - 1).ClearContents
Set P = [A1].CurrentRegion
On Error Resume Next
Set Wapp = GetObject(, "Word.Application")
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application")
While doc <> ""
    Wapp.documents(doc).Close False 'si le document est ouvert on le ferme
    With Wapp.documents.Open(chemin & doc)
        For i = 2 To P.Rows.Count
            If InStr(.Range, P(i, 1)) Then P(i, Columns.Count).End(xlToLeft)(1, 2) = .Name
        Next
        .Close
    End With
    doc = Dir 'document suivant
Wend
Wapp.Quit
Columns.AutoFit 'ajustement largeurs
If Columns(1).ColumnWidth < 13 Then Columns(1).ColumnWidth = 13
End Sub

Sub Rechercher()
Dim chemin$, doc$, P As Range, i&
chemin = ThisWorkbook.Path & "\" 'à adapter
doc = Dir(chemin & "*.doc*") '1er document du dossier
Application.ScreenUpdating = False
[B2].Resize(Rows.Count - 1, Columns.Count - 1).ClearContents
Set P = [A1].CurrentRegion
While doc <> ""
    With GetObject(chemin & doc)
        For i = 2 To P.Rows.Count
            If InStr(.Range, P(i, 1)) Then P(i, Columns.Count).End(xlToLeft)(1, 2) = .Name
        Next
        .Close
    End With
    doc = Dir 'document suivant
Wend
Columns.AutoFit 'ajustement largeurs
If Columns(1).ColumnWidth < 13 Then Columns(1).ColumnWidth = 13
End Sub