Rechercher un mot dans un fichier word à partir de Excel VBA

Bonjour, je débute sur Excel vba et souhaiterai, à partir de mon fichier Excel, ouvrir un fichier Word, rechercher un mot puis refermer le fichier et indiquer dans Excel à quelles pages se trouve le mot.

J'ai saisis mon programme, celui-ci ouvre le fichier word que je lui ai indiqué, réussi à le refermer, mais n'effectue pas la recherche de mot (L'étape la plus importante).

Si quelqu'un peut m'aider à résoudre mon problème cela m'aiderai beaucoup car je suis complètement bloqué.

Voici le programme:

Option ExplicitPublic Const wdActiveEndAdjustedPageNumber = 1

Public T As Variant

Sub Import_Doc()Dim lg As Integer

With Sheets("RECHERCHE")

Worksheets("RECHERCHE").Range("H9:J9").Clear

lg = .Cells(Rows.Count, 1).End(xlUp).Row

T = Range("G9:J9" & lg).Value

Worksheets("RECHERCHE").Range("G9").Resize(UBound(T, 1), UBound(T, 2)) = T

Dim WordApp As Object, WordDoc As Object

Dim i As Integer Set WordApp = CreateObject("Word.Application")

Set WordDoc = CreateObject("Word.Document")

WordApp.Documents.Open "V:\Localisation dossier.docx"

WordApp.Visible = True

For i = 1 To UBound(T, 1)

With WordDoc.Content.Find

.Text = T(i, 1)

.Forward = True

.MatchWholeWord = True

While .Execute

If .Found Then

.Parent.Select

T(i, 2) = IIf(T(i, 2) = "", "", T(i, 2) & " ") & _

WordApp.Selection.Information(wdActiveEndAdjustedPageNumber)

T(i, 3) = T(i, 3) + 1

Else

T(i, 2) = "Non trouvé"

End If

Wend

End With

Next i

WordDoc.Close WordApp.Application.Quit

Set WordApp = Nothing

End With

End Sub

En faisant défiler le programme avec F8, celui-ci saute l'étape:

Merci d'avance pour votre aide

.Parent.Select

T(i, 2) = IIf(T(i, 2) = "", "", T(i, 2) & " ") & _ WordApp.Selection.Information(wdActiveEndAdjustedPageNumber)

T(i, 3) = T(i, 3) + 1

Merci d'avance pour votre aide

Bonjour,

Avez-vous la possibilité de mettre vos fichiers Excel et Word sans données confidentielles en ligne ?

Voici le fichier excel et le word en question:

Merci d'avance

Option Explicit

Sub Import_Doc()

Dim I As Integer, Lg As Integer, NbTrouve As Integer
Dim WordApp As Object, WordDoc As Object
Dim Chemin As String
Dim AireRecherche As Range

    Set AireRecherche = Range("t_Recherche[Mot à rechercher]")
    Range(AireRecherche.Offset(0, 1), AireRecherche.Offset(0, 3)).ClearContents
    Chemin = ActiveWorkbook.Path & "\" & "Li_llkrm 2022-04-13 Ex-P word-recherche.docx"
    NbTrouve = 0

    Set WordApp = CreateObject("Word.Application")
    With WordApp
         Set WordDoc = .Documents.Open(Chemin) '"word.recherche.docx"
         .Visible = True
         For I = 1 To AireRecherche.Count
                With WordDoc.Content.Find
                    .Text = AireRecherche(I)
                    .Forward = True
                    .MatchWholeWord = True
                    While .Execute
                          If .Found Then
                             .Parent.Select
                             NbTrouve = NbTrouve + 1
                             AireRecherche(I).Offset(0, 1) = AireRecherche(I).Offset(0, 1) & WordApp.Selection.Information(1) & ", "
                             AireRecherche(I).Offset(0, 2) = NbTrouve
                          End If
                     Wend
                End With
                If NbTrouve = 0 Then
                    AireRecherche(I).Offset(0, 1) = "Non trouvé"
                Else
                    AireRecherche(I).Offset(0, 1) = Mid(AireRecherche(I).Offset(0, 1), 1, Len(AireRecherche(I).Offset(0, 1)) - 2)
                End If
         Next I
    End With

    WordDoc.Close
    WordApp.Quit

    Set WordApp = Nothing:  Set WordDoc = Nothing

 End Sub

Super merci c'est exactement ce que je cherchais à faire!

Une dernière chose il y aurait-il moyen d'ajouter quelque lignes dans le programme afin d'afficher le nom du document word dans la cellule "DTU" du fichier Excel?

Sinon c'est parfait merci beaucoup!

                If NbTrouve = 0 Then
                    AireRecherche(I).Offset(0, 1) = "Non trouvé"
                Else
                    AireRecherche(I).Offset(0, 1) = Mid(AireRecherche(I).Offset(0, 1), 1, Len(AireRecherche(I).Offset(0, 1)) - 2)
                End If
                AireRecherche(I).Offset(0, 3) = WordDoc.Name
         Next I

J'aimerai également bouclé le programme afin qu'il exécute tout ça pour plusieurs fichiers Word et que les infos "pages, occurences, dtu" soient stockés l'une en dessous de l'autre pour chaque fichier?

Merci d'avance