Chercher un mot ds ts les docs d'un rép. et copie des paragraphes ds doc principal

[ouskel'n'or]

But :Rassembler dans un document principal (ThisDocument) les paragraphes contenant un mot de tous les document Word d'un répertoire défini.

Le principe :
Tant qu'un Document existe dans le répertoire :
- Ouverture de chaque Document
- Recherche du mot
- Copie du paragraphe qui le contient
- Collage dans le document principal
- Fermeture du document
Fin Tant que

Les procédures
Sub Appel() :
- Vérifie l'existence du répertoire
- Crée une nouvelle instance de Word
- Lance l'ouverture des documents successifs

Sub Lister(Chemin$, LeMot$) :Tant qu'un document existe dans le répertoire :
- Liste les fichiers du répertoire
- Ouvre chaque fichiers
- Lance la recherche du mot
- Sélectionne et copie le paragraphe dans le document principal
- Crée un lien hypertexte vers le document objet de la recherche
- Ferme ce document
Fin tant que

Fonction Chercher(LeMot$) :
- Vérifie l'existence du mot dans le document ouvert
- Renvoie la réponse à la procédure Lister()

Pour tester, coller ces trois procédures dans une module standard et exécuter la procédure Appel()

Le code :

Option Explicit
 
Public appWd As Object
Public LeDoc As Object
 
Sub Appel()
Dim Chemin$, Tablo As Variant, LeMot$
    Set appWd = CreateObject("Word.Application")
    appWd.Visible = False
    Chemin = "D:\Doc\Essai\"
    If Not Dir(Chemin) <> "" Then
        MsgBox "Répertoire inexistant"
        Exit Sub
    End If
    LeMot = InputBox("Saisir le mot à chercher", "RECHERCHE", "Le mot")
    CreateObject("Wscript.shell").Popup "Minute papillon, je bosse !", 1, "PATIENCE, ÇA VIENT !"
    If Trim(LeMot) <> "" Then
        Lister Chemin, LeMot
    End If
    appWd.Quit
    Set appWd = Nothing
    MsgBox "èf' I... FI, èn' i... NI c'est  FINI !"
End Sub

Liste les fichiers (*.doc) du répertoire

Sub Lister(Chemin$, LeMot$)
Dim NomFich$
Dim LeDoc As Document
    NomFich = Dir(Chemin & "*.doc")
    'Vérification de l'existence de fichiers dans le répertoire
    If NomFich = "" Then
        MsgBox "Aucun fichier dans le répertoire " & Chemin
        Exit Sub
    End If
    
    'Ouverture des fichiers du répertoire
    Do While NomFich <> ""
        Set LeDoc = appWd.Documents.Open(Chemin & NomFich)
        DoEvents
        'Lance la recherche
        If Chercher(LeMot) Then
            'Insère un saut de ligne avant de coller le paragraphe
            ThisDocument.Range.InsertAfter vbCrLf
            'renvoie en début de ligne
            appWd.Selection.HomeKey Unit:=wdLine
            
            'Sélectionne le paragraphe
            appWd.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
            
            'Copie le paragraphe
            appWd.Selection.Copy
            
            'Colle le paragraphe dans le document principal
            ThisDocument.Select
            Selection.EndKey Unit:=wdStory
            Selection.PasteAndFormat (wdPasteDefault)
            
            'Insère un saut de ligne
            ThisDocument.Range.InsertAfter vbCrLf
            
            'Crée un lien hypertexte vers le document contenant le mot
            ThisDocument.Hyperlinks.Add Address:=Chemin & "\" & NomFich, _
                Anchor:=Selection.Range
        End If
        
        'Ferme le document objet de la recherche
        LeDoc.Close False
        Set LeDoc = Nothing
        DoEvents
        
        'Passe au fichier suivant
        NomFich = Dir
    Loop
End Sub

'Recherche du mot dans le fichier ouvert
Function Chercher(LeMot$) As Boolean
    With appWd.Selection.Find
        .Text = LeMot
        Chercher = .Execute
    End With
End Function

Le but d'ouvrir une nouvelle instance de Word :
- Accélérer appréciablement la procédure.
- Eviter accessoirement les mouvements de feuilles

[ouskel'n'or]

Pour ajouter un lien avec les fichiers, deux options :
- Lien placé en tête des paragraphes copiés dans le doc principal,
- Lien placé après copie de ces paragraphes.

Placer le lien en tête des paragraphes copiés (Sub Appel inchangée)

Sub Appel()
Dim Chemin$, Tablo As Variant, LeMot$
    Chemin = "D:\Doc\Essai\"
    If Not Dir(Chemin) <> "" Then
        MsgBox "Répertoire inexistant"
        Exit Sub
    End If
    Set appWd = CreateObject("Word.Application")
    appWd.Visible = False
    LeMot = InputBox("Saisir le mot à chercher", "RECHERCHE", "Options")
    CreateObject("Wscript.shell").Popup "Minute papillon, je bosse !", 1, "PATIENCE, ÇA VIENT !"
    If Trim(LeMot) <> "" Then
        Lister Chemin, LeMot
    End If
    appWd.Quit
    Set appWd = Nothing
    MsgBox "èf' I... FI, èn' i... NI c'est  FINI !"
End Sub

'Liste les fichiers (*.doc) du répertoire
Sub Lister(Chemin$, LeMot$)
Dim NomFich$
Dim LeDoc As Document
    NomFich = Dir(Chemin & "*.doc")
    'Vérification de l'existence de fichiers dans le répertoire
    If NomFich = "" Then
        MsgBox "Aucun fichier dans le répertoire " & Chemin
        Exit Sub
    End If
    
    'Ouverture des fichiers du répertoire
    Do While NomFich <> ""
        Set LeDoc = appWd.Documents.Open(Chemin & NomFich)
        DoEvents
        'Lance la recherche
        Chercher LeMot, Chemin & NomFich
        'Ferme le document objet de la recherche
        LeDoc.Close False
        Set LeDoc = Nothing
        DoEvents
        
        'Passe au fichier suivant
        NomFich = Dir
    Loop
End Sub

'Recherche du mot dans le fichier ouvert
Sub Chercher(LeMot$, NomComplet$)
Dim Lien As Boolean
    'Utile pour n'insérer le lien qu'une seule fois, ici avant copie des paragraphes
    Lien = True
    
    'Place en début de doc avant de lancer la recherche
    appWd.Selection.HomeKey Unit:=wdStory
    
    With appWd.Selection.Find
        .ClearFormatting
        
        'Début la boucle de recherche : Tant que la donnée est trouvée, on continue
        Do While .Execute(FindText:=LeMot, Forward:=True, _
                  Wrap:=wdFindStop)
                  
            'Crée un lien hypertexte vers le document contenant le mot
            If Lien Then
                'Insère un saut de ligne avant de coller le lien
                ThisDocument.Range.InsertAfter vbCrLf
                ThisDocument.Hyperlinks.Add Address:=NomComplet$, _
                Anchor:=Selection.Range
                Lien = False
            End If
            
            'Insère un saut de ligne avant de coller le paragraphe
            ThisDocument.Range.InsertAfter vbCrLf
            
            'renvoie en début de ligne
            appWd.Selection.HomeKey Unit:=wdLine
            
            'Sélectionne le paragraphe
            appWd.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
            
            'Copie le paragraphe
            appWd.Selection.Copy
            
            'Colle le paragraphe dans le document principal
            ThisDocument.Select
            Selection.EndKey Unit:=wdStory
            Selection.PasteAndFormat (wdPasteDefault)
            
            'Insère un saut de ligne
            ThisDocument.Range.InsertAfter vbCrLf
            
            appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1
        Loop
    End With
    
End Sub

Placer le lien en fin de paragraphes
Ici encore la procédure d'appel est inchangée mais la procédure Chercher redevient une fonction.

'Liste les fichiers (*.doc) du répertoire
Sub Lister(Chemin$, LeMot$)
Dim NomFich$
Dim LeDoc As Document
    NomFich = Dir(Chemin & "*.doc")
    'Vérification de l'existence de fichiers dans le répertoire
    If NomFich = "" Then
        MsgBox "Aucun fichier dans le répertoire " & Chemin
        Exit Sub
    End If
    
    'Ouverture des fichiers du répertoire
    Do While NomFich <> ""
        Set LeDoc = appWd.Documents.Open(Chemin & NomFich)
        DoEvents
        'Lance la recherche
        If Chercher(LeMot) Then
            'Insère un saut de ligne avant de coller le lien
            ThisDocument.Range.InsertAfter vbCrLf
            
            'Crée un lien hypertexte vers le document contenant le mot
            ThisDocument.Hyperlinks.Add Address:=Chemin & NomFich, _
                Anchor:=Selection.Range
        End If
 
        'Ferme le document objet de la recherche
        LeDoc.Close False
        Set LeDoc = Nothing
        DoEvents
        
        'Passe au fichier suivant
        NomFich = Dir
    Loop
End Sub

'Recherche du mot dans le fichier ouvert
Function Chercher(LeMot$) As Boolean
    'Place en début de document ouvert pour effectuer la recherche
    appWd.Selection.HomeKey Unit:=wdStory
    
    'Lance la recherche
    With appWd.Selection.Find
        .ClearFormatting
        
        'Début la boucle de recherche : Tant que la donnée est trouvée, on continue
        Do While .Execute(FindText:=LeMot, Forward:=True, _
                  Wrap:=wdFindStop)
                  
            'renvoie en début de ligne pour coller le paragraphe
            appWd.Selection.HomeKey Unit:=wdLine
            
            'Sélectionne le paragraphe à copier
            appWd.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
            
            'Copie le paragraphe
            appWd.Selection.Copy
            
            'Colle le paragraphe dans le document principal
            ThisDocument.Select
            Selection.EndKey Unit:=wdStory
            Selection.PasteAndFormat (wdPasteDefault)
            
            'Insère un saut de ligne avant de coller le lien
            ThisDocument.Range.InsertAfter vbCrLf
            
            'Place sur le premier caractère de la ligne suivante
            appWd.Selection.MoveRight Unit:=wdCharacter, Count:=1
            
            ''Utile afin de savoir si le lien doit être incorporé, ici en fin de copie
            Chercher = True
        
        Loop 'la recherche cesse quand fin doc atteinte (Wrap:=wdFindStop)
    End With
    
End Function

NB - Pour ne pas créer de lien, supprimer la ligne

Lien = True

dans le premier cas et

Chercher = True

dans le second.