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

[Hedi69]

Bonjour à tous,

J'aimerai votre aide svp pour faire une recherche, je m'explique:

Dans la colonne A d'un fichier excel j'ai une liste de numéros de série.

Dans un répertoire de mon PC (C:\Devis) j'ai un tas de devis au format docx.

Je dois retrouver pour chaque numéro de série, le nom du fichier ou il apparait.

le numéro de serie se trouve dans le contenu du devis et non dans le titre.

J'aimerai obtenir dans la colonne B le nom du fichier où le numéro de série apparait.

Merci infiniment

exemple de devis en attachement.

 

[job75]

Bonsoir ghghg,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Ouvrez le fichier Excel et cliquez sur le bouton pour exécuter cette macro :

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

Bonne nuit.

 

[job75]

Bonjour ghghg,

En fait il n'est pas nécessaire de créer une instance de Word, voyez ce fichier (2) avec :

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

Avec le fichier (1) Excel plante si plus d'un fichier source est ouvert quand on lance la macro.

Edit : curieux, plantait hier soir mais pas ce matin...

Avec ce fichier (2) pas de problème.