Recherche a partir d'Excel dans Word

Messieurs,
 
Je lutte un peu pour écrire une macro excel pour traiter un fichier word. Je souhaiterais qu'elle:
 
- ouvre le fichier word en question
- parcourt le fichier word a la recherche d'un certain mot
- à chaque fois qu'elle trouve le mot, copier un certain nombre de caractères qui suivent ce mot dans la cellule A1 du fichier excel
- continuer ceci jusqu'a la fin du fichier word en copiant à chaque fois dans le fichier excel les caractères  dans les cellules suivantes A2,A3....
 
Voila mon code, le pb est que il s'arrète à la première occurence trouvée...
 
Sub Extraction()
 
    Dim appWD As New Word.Application
    Dim DocWD As New Word.Document
    Set DocWD = appWD.Documents.Open("C:\test.txt" )
     
    appWD.Visible = True
    appWD.Selection.Find.ClearFormatting
     
    With appWD.Selection.Find
        .Text = "numéro:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   
     
    Do While appWD.Selection.Find.Execute("numéro:" ) = True
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
        appWD.Selection.Copy
        Range("A1" ).Select
        ActiveSheet.Paste
        ActiveCell.Offset(1, 0).Select
    Loop
     
DocWD.Close True
appWD.Quit
Set DocWD = Nothing
Set appWD = Nothing
 
End Sub



Un grand merci pour votre aide!
 
Paul

Salut, en effet, je cherches mais je vois pas pourquoi. Tu as pourtant un exemple tres proche de celui de l'aide.

J'ai remplacé Selection par ActiveDocument.Content mais rien n'y change.

Tu vas pas le croire je viens de trouvé. Ouvre ton fichier Txt avec word et regarde comment c'est écrit "numéro".

Ca doit venir du codage du fichier texte.

Donc c'est normal que tu ne trouve pas le mot en question puisque word ecrit différemment.

Essaies en remplacant les "numéro" par "numero" (c a d sans l'accent) et moi ca a fonctionné directe.

voila, c'est bon j'ai la solution,

modifie la méthode open comme ceci:


    Set DocWD = appWD.Documents.Open("C:\Documents and Settings\BorelNi\Bureau\test.txt", Encoding:=msoEncodingWestern)

et tu verras que word affiche bien et que par consequent, le nom est bien trouvé. Dis moi si ca resoud ton pb.

A+

Salut Nicko,

Tout d'abord merci pour ton aide!! J'ai modifié le script comme tu me le conseilles mais la boucle Do while ne marche toujours pas. En fait il copie colle bien la première occurence mais ensuite il s'arrête et donc ne copie colle pas les autres présentes dans le fichier! Le test Do While appWD.Selection.Find.Execute("numéro:" ) = True  est-il bon dans la boucle?

Encore merci!

Je te mets le code que j'ai modifié (et qui marche nickel):

et OUI ton test est bon.

Le truc, c'est que je viens de trouvé un bug. Quand j'execute et que je remet au premier plan le fichier text a chaque occurence ca marche.
J'essaies de trouver d'ou cela viens (essaies aussi de voir ca).

Public Sub Extraction()
 
    Dim appWD As New Word.Application
    Dim DocWD As New Word.Document
    Set DocWD = appWD.Documents.Open("C:\Documents and Settings\BorelNi\Bureau\Test_Module\test.txt", Encoding:=msoEncodingWestern)
    
    appWD.Visible = True
    
    With appWD.Selection.Find
        .ClearFormatting
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   
    
    Do While appWD.Selection.Find.Execute("numero:") = True
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
        appWD.Selection.Copy
        Range("A1").Select
        ActiveSheet.Paste
        ActiveCell.Offset(1, 0).Select
    Loop
    
DocWD.Close True
appWD.Quit
Set DocWD = Nothing
Set appWD = Nothing

End Sub

Je viens de trouver, voici le code qui marche! (j'ai mis en gras les 2 modifs). En fait il me sélectionnait tout le document et s'arrêtait.
Merci pour ton aide Nicko!
+

Sub Extraction()
 
    Dim appWD As New Word.Application
    Dim DocWD As New Word.Document
    Set DocWD = appWD.Documents.Open("C:\test.txt" )
     
    appWD.Visible = True
    appWD.Selection.Find.ClearFormatting
     
    With appWD.Selection.Find
        .Text = "numéro:"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
   
   Range("A1" ).Select
    
    Do While appWD.Selection.Find.Execute("numéro:" ) = True
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
        appWD.Selection.Copy
        appWD.Selection.MoveRight Unit:=wdCharacter, Count:=1
        ActiveSheet.Paste
        ActiveCell.Offset(1, 0).Select
    Loop
     
DocWD.Close True
appWD.Quit
Set DocWD = Nothing
Set appWD = Nothing
 
End Sub