Rechercher dans word des mots et créer une liste excel

Sub manu()
'activer la référence "Microsoft Word xx.x Object Library"
Dim Cible As String
Dim AppWord As Word.Application
Dim DocWord As Word.Document
Dim CollWord As Word.Words
Dim i As Long, j As Long
 
Cible = "C:\test\test1.doc"
Set AppWord = New Word.Application
AppWord.Visible = False
Set DocWord = AppWord.Documents.Open(Cible)
Set CollWord = DocWord.Content.Words
 
For i = 1 To CollWord.Count
    If InStr(1, CollWord(i), "maison") > 0 Then
        j = j + 1
        Cells(j, 1) = CollWord(i) & CollWord(i + 1) & CollWord(i + 2): Cells(j, 2) = Cible
    End If
     If InStr(1, CollWord(i), "jardin") > 0 Then
        j = j + 1
        Cells(j, 1) = CollWord(i) & CollWord(i + 1) & CollWord(i + 2): Cells(j, 2) = Cible
    End If
Next
DocWord.Close True
AppWord.Quit
End Sub

Sub manu()
'activer la référence "Microsoft Word xx.x Object Library"
Dim Cible As String
Dim AppWord As Object ' Word.Application
Dim DocWord As Object 'As Word.Document
Dim CollWord As Object 'Word.Words
Dim i As Long, j As Long
 
Cible = "C:\test\test1.doc"
Set AppWord = CreateObject("Word.Application")
'Set AppWord = New Word.Application
AppWord.Visible = False
Set DocWord = AppWord.Documents.Open(Cible)
Set CollWord = DocWord.Content.Words
 
For i = 1 To CollWord.Count
    If InStr(1, CollWord(i), "maison") > 0 Then
        j = j + 1
        Cells(j, 1) = CollWord(i) & CollWord(i + 1) & CollWord(i + 2): Cells(j, 2) = Cible
    End If
     If InStr(1, CollWord(i), "jardin") > 0 Then
        j = j + 1
        Cells(j, 1) = CollWord(i) & CollWord(i + 1) & CollWord(i + 2): Cells(j, 2) = Cible
    End If
Next
DocWord.Close True
AppWord.Quit
End Sub

Sub manu()
'activer la référence "Microsoft Word xx.x Object Library"
Dim Cible As String
Dim AppWord As Object 'Word.Application
Dim DocWord As Object 'Word.Document
Dim CollWord As Object 'Word.Words
Dim i As Long, j As Long
 
Cible = "C:\test\test3.doc"
Set AppWord = CreateObject("Word.Application")
'Set AppWord = New Word.Application
AppWord.Visible = False
Set DocWord = AppWord.Documents.Open(Cible)
Set CollWord = DocWord.Content.Words

For i = 1 To CollWord.Count
'Cells(i, 10) = RTrim(CollWord(i))
    t = ""
    'gestion des Maisons
    If InStr(1, LCase(CollWord(i)), "maison") > 0 Then
        j = j + 1
        t = CollWord(i)
        For x = i + 1 To Application.WorksheetFunction.Max(i + 10, CollWord.Count)
            If Right(CollWord(x), 1) <> " " Then
                t = t & CollWord(x)
            Else
                t = t & CollWord(x)
                Exit For
            End If
        Next x
        Cells(j, 1) = t: Cells(j, 2) = Cible
    End If
    'gestion des jardins
    If InStr(1, LCase(CollWord(i)), "jardin") > 0 Then
        j = j + 1
        t = CollWord(i)
        For x = i + 1 To Application.WorksheetFunction.Max(i + 10, CollWord.Count)
            If Right(CollWord(x), 1) <> " " Then
                t = t & CollWord(x)
            Else
                t = t & CollWord(x)
                Exit For
            End If
        Next x
        Cells(j, 1) = t: Cells(j, 2) = Cible
    End If
Next
DocWord.Close True
AppWord.Quit
Set DocWord = Nothing
Set AppWord = Nothing

End Sub