Recherche texte dans fichier WORD corps/entete/piedPAge Excel VBA

Bonjour,

Je souhaite recherche un mot dans une liste de fichier Word stockés dans un même répertoire et de constituer une liste qui spécifie que le mot a été trouvé au moins une fois dans le corps du texte dans au moins une des entêtes ou dans au moins un des pieds de pages.

J'arrive à repérer dans le corps de chaque Word mais je n'arrive pas à faire la recherche dans le pied de page

J'ai récupéré un morceau de code qui fonctionne très bien si la macro est exécutée depuis le Word mais je n'arrive pas à l'adapter pour qu'elle fonctionne depuis un Excel.

Merci de votre aide

Sub RechercherMot()

' -- Variables declaration
Dim wb As Workbook 'classeur Excel dans lequel on importe les données
Dim ws As Worksheet 'onglet Excel dans lequel on importe les données
Dim sChemin As String 'répertoire contenant les fichiers Word
Dim sNomFichier As String 'nom du fichier Word
Dim WApp As Object, WDoc As Object, WSel As Object, WSel2 As Object
Dim i As Integer
Dim j As Integer
Dim Max As Integer
Dim FindMe As String
Dim Motcletrouve As Boolean
Dim xDoc As Object
Dim xFooter As HeaderFooter

FindMe = InputBox(Prompt:=" Find a specific word ")
Max = 2
' Cells(1, 2) = findMe
' -- Variables initialisation
Set wb = ThisWorkbook
Set ws = wb.Sheets(1) 'on sauvegarde dans la 1re feuille
sChemin = ChoisirRepertoire & "\" 'fonction pour choisir le répertoire contenant les fichier Word
'sChemin = ThisWorkbook.Path & "\" 'si les fichiers Word se trouvent dans le même répertoire que le fichier Excel
sNomFichier = Dir(sChemin & "*.doc*") 'pour ouvrir tous les fichiers .doc*. 1er fichier.

Set WApp = CreateObject("Word.Application") 'pour créer un objet Word
WApp.Visible = True 'ne pas afficher Word pendant l'exécution
i = ws.Range("A" & Rows.Count).End(xlUp).Row + 1 '1re ligne où on va écrire les données dans le fichier Excel

Application.ScreenUpdating = False

' -- Boucle sur les fichiers
Do While Len(sNomFichier) > 0

Set WDoc = WApp.Documents.Open(sChemin & sNomFichier) 'ouvre le document Word
'Application.StatusBar = "Écriture ligne " & i 'message dans Excel pour voir la progression

' Nom du fichier
ws.Cells(i, 1) = sNomFichier
'ws.Cells(i, 2) = findMe

' rechercher dans corps de texte, entête et pied de page
WApp.Selection.HomeKey Unit:=6 'Retourne au début du fichier Word
WApp.Selection.Find.ClearFormatting 'on "vide la mémoire" de la fonction Recherche
With WApp.Selection.Find
.Text = FindMe
.Forward = True
'.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False

End With

'Selection.Find.Execute

Motcletrouve = WApp.Selection.Find.Execute

If Motcletrouve = True Then
Cells(i, 2) = " Oui"
End If

'*********************** DEBUT DU GRAND n'importe quoi !

Motcletrouve = False
WDoc.Activate
WApp.Selection.HomeKey Unit:=6
On Error Resume Next
Set xDoc = Application.ActiveDocument
For Each xSec In xDoc.Sections
For Each xFooter In xSec.footers
xFooter.Range.Select
Set xSelection = xDoc.Application.Selection
With xSelection.Find
.Text = FindMe 'Enter the old footer text here!
'.Replacement.Text = "I've found footer text" 'Enter the old footer text here!
.Forward = True
.Wrap = wdFindContinue
'.Execute 'Replace:=wdReplaceAll
End With
Motcletrouve = xSelection.Find.Execute
If Motcletrouve Then
Cells(i, 3) = " Oui"
Exit For
End If
Next xFooter
Next xSec
xDoc.ActiveWindow.ActivePane.Close
If xDoc.ActiveWindow.View.SplitSpecial = wdPaneNone Then
xDoc.ActiveWindow.View.Type = wdPrintView
Else
xDoc.ActiveWindow.View.Type = wdPrintView
End If
xDoc.Activate

Motcletrouve = False

' fin du grand n'importe quoi************************

i = i + 1 'prochaine ligne
'WDoc.Save
WDoc.Close False 'fermer le document Word sans enregistrer

sNomFichier = Dir 'prochain document
Loop

SortieNormale:
Application.ScreenUpdating = True
WApp.Quit 'Fermer l'instance de Word
Application.StatusBar = False 'Remise à zéro de la barre d'état
Set wb = Nothing
Set ws = Nothing
Set WApp = Nothing
Set WDoc = Nothing
Set WSel = Nothing
Set WApp = Nothing

End Sub

'====================================
'Function to chose the folder containing the .doc files
'====================================

Function ChoisirRepertoire() As String
Dim oRepertoire As Object
ChoisirRepertoire = ""
Set oRepertoire = CreateObject("Shell.Application").BrowseForFolder(0, "Choisir un répertoire", 0)
If (Not oRepertoire Is Nothing) Then ChoisirRepertoire = oRepertoire.Items.Item.Path
Set oRepertoire = Nothing
End Function

'************Code de la Macro qui fonctionne parfaitement dans un fichier Word

Sub FindAndReplaceOfHeaderAndFooter()
'Update by Extendoffice 20190805
Dim xDoc As Document
Dim xSelection As Selection
Dim xSec As Section
Dim xHeader As HeaderFooter
Dim FindMe As String
Dim trouve As Boolean

Dim xFooter As HeaderFooter

FindMe = "Oyon"

On Error Resume Next
Set xDoc = Application.ActiveDocument
For Each xSec In xDoc.Sections
For Each xHeader In xSec.Headers
xHeader.Range.Select
Set xSelection = xDoc.Application.Selection
With xSelection.Find
.Text = FindMe 'Enter the old header text here!
'.Replacement.Text = "I've found header text" 'Enter the new header text here!
.Wrap = wdFindContinue
'.Execute 'Replace:=wdReplaceAll
End With
trouve = xSelection.Find.Execute
If trouve Then
MsgBox "Trouvé entete"
'Exit For
End If
Next xHeader
For Each xFooter In xSec.Footers
xFooter.Range.Select
Set xSelection = xDoc.Application.Selection
With xSelection.Find
.Text = FindMe 'Enter the old footer text here!
'.Replacement.Text = "I've found footer text" 'Enter the old footer text here!
.Wrap = wdFindContinue
'.Execute 'Replace:=wdReplaceAll
End With
trouve = xSelection.Find.Execute
If trouve Then
MsgBox "Trouvé pied de page"
'Exit For
End If
Next xFooter
Next xSec
xDoc.ActiveWindow.ActivePane.Close
If xDoc.ActiveWindow.View.SplitSpecial = wdPaneNone Then
xDoc.ActiveWindow.View.Type = wdPrintView
Else
xDoc.ActiveWindow.View.Type = wdPrintView
End If
xDoc.Activate
End Sub

Edit modo : merci de mettre le code entre balises SVP avec le bouton </>

Bonjour,

Essayer ce code :

Sub RechercherMot()

    ' -- Variables declaration
    Dim wb As Workbook 'classeur Excel dans lequel on importe les données
    Dim ws As Worksheet 'onglet Excel dans lequel on importe les données
    Dim sChemin As String 'répertoire contenant les fichiers Word
    Dim sNomFichier As String 'nom du fichier Word
    Dim WDoc As Object, Wapp As Object
    Dim i As Integer
    Dim FindMe As String, FindHeader As Boolean, FindContent As Boolean, FindFooter As Boolean

    FindMe = InputBox(Prompt:=" Find a specific word ")

    ' -- Variables initialisation
    Set wb = ThisWorkbook
    Set ws = wb.Sheets(1) 'on sauvegarde dans la 1re feuille
    sChemin = ChoisirRepertoire & "\" 'fonction pour choisir le répertoire contenant les fichier Word
    sNomFichier = Dir(sChemin & "*.doc*") 'pour ouvrir tous les fichiers .doc*. 1er fichier.

    Application.ScreenUpdating = False

    ' -- Boucle sur les fichiers
    i = 1
    Do While Len(sNomFichier) > 0
        Set WDoc = GetObject(sChemin & sNomFichier) 'ouvre le document Word
        Set Wapp = WDoc.Application

        ' rechercher dans corps de texte, entête et pied de page
        Recherche WDoc, FindMe, FindContent, FindHeader, FindFooter

        ' remplissage ligne
        On Error Resume Next
        i = ws.Columns("A").Find("").Row  '1re ligne où on va écrire les données dans le fichier Excel
        On Error GoTo 0
        ws.Cells(i, 1) = sNomFichier
        If FindContent Then ws.Cells(i, 2) = "oui"
        If FindHeader Then ws.Cells(i, 3) = "oui"
        If FindFooter Then ws.Cells(i, 4) = "oui"

        WDoc.Close False 'fermer le document Word sans enregistrer

        sNomFichier = Dir 'prochain document
    Loop

SortieNormale:
    Application.ScreenUpdating = True
    Wapp.Quit 'Fermer l'instance de Word
    Application.StatusBar = False 'Remise à zéro de la barre d'état
    Set wb = Nothing
    Set ws = Nothing
    Set WDoc = Nothing

End Sub

'====================================
'Function to chose the folder containing the .doc files
'====================================

Function ChoisirRepertoire() As String
    Dim oRepertoire As Object

    ChoisirRepertoire = ""
    Set oRepertoire = CreateObject("Shell.Application").BrowseForFolder(0, "Choisir un répertoire", 0)
    If (Not oRepertoire Is Nothing) Then ChoisirRepertoire = oRepertoire.Items.Item.Path
    Set oRepertoire = Nothing

End Function

'************Procédure de recherche dans fichier Word

Sub Recherche(xDoc As Object, FindMe As String, FindContent As Boolean, FindHeader As Boolean, FindFooter As Boolean)
    Dim xSec As Object, xHeader As Object, xFooter As Object, xbody As Object

    For Each xSec In xDoc.Sections

        With xDoc.Content.Find
            .Text = FindMe
            FindContent = False
            If .Execute Then FindContent = True
        End With

        For Each xHeader In xSec.Headers
            FindHeader = False
            With xHeader.Range.Find
                .Text = FindMe
                If .Execute Then FindHeader = True: Exit For
            End With
        Next xHeader

        For Each xFooter In xSec.Footers
            FindFooter = False
            With xFooter.Range.Find
                .Text = FindMe
                If .Execute Then FindFooter = True: Exit For
            End With
        Next xFooter

    Next xSec

End Sub