Sub rechercheEtPhrases()

' crée un nouveau document avec les phrases qui contiennent un des mots recherchés
' ainsi que les phrases précèdent ou suivent ces phrases
Const nbPhrasesAvant As Long = 2
Const nbPhrasesAprès As Long = 1

Dim doc As Document, ND As Document
Dim mon_texte As String
Dim tableauMots() As String ' les mots à rechercher
Dim tableauPhrases() As Boolean  ' mémorise si le texte a été trouvé dans cette ˆhrase
Dim i As Long, j As Long, k As Long, l As Long, ic As Long
Dim texte_para As String
Dim cpt1 As Long
Dim cpt2 As Long
Dim numPhrase As Long
mon_texte = InputBox("Quel(s) mot(s) voulez-vous trouver ?", "Mots séparés par une virgule")


If mon_texte = "" Then Exit Sub
tableauMots = Split(mon_texte, ",")
For i = 0 To UBound(tableauMots())
  tableauMots(i) = Trim(tableauMots(i))
Next i
Set doc = ActiveDocument
ReDim tableauPhrases(doc.Sentences.count + 1) ' Sentences(0) n'existe pas
For i = 0 To UBound(tableauPhrases())
  tableauPhrases(i) = False
Next i
Application.ScreenUpdating = False
'Recherche de tous les mots
cpt1 = 0 ' nombre de trouvailles
For i = 0 To UBound(tableauMots()) ' boucle sur le nb de mots à chercher
  Selection.HomeKey Unit:=wdStory
  Do
      Selection.Find.ClearFormatting
      With Selection.Find
        .ClearFormatting
        .Text = tableauMots(i)
        .Forward = True
        .Wrap = wdFindStop
        .MatchCase = False
        .MatchWildcards = False
        .MatchAllWordForms = False
        .MatchWholeWord = True
        .Execute
    End With

      If Selection.Find.Found Then
        Selection.Range.HighlightColorIndex = wdYellow
        numPhrase = doc.Range(Start:=1, End:=Selection.End).Sentences.count
           ' mémorisation de la pharse concernée, indices décalés de 1 entre  tableau / Pharses
        tableauPhrases(numPhrase) = True
        cpt1 = cpt1 + 1
      End If
      DoEvents
    Loop Until Not Selection.Find.Found
  Next i

'On crée le nouveau doc et on y insère les textes trouvés
    Set ND = Documents.Add
    j = 1
    cpt2 = 0 ' comptage des paragraphes

    For i = 1 To UBound(tableauPhrases)
    ' recopié des § concernés et attenants
    ' tableau (0) est ignoré car la numéotation des § commence à 1
    
    If tableauPhrases(i) = True Then
      Selection.EndKey Unit:=wdStory, Extend:=wdMove
      ND.Range.InsertAfter " Trouvaille " & j & "-----------------------"
      Selection.EndKey Unit:=wdStory, Extend:=wdMove
      Selection.TypeParagraph
      k = i - nbPhrasesAvant
      If k < 1 Then k = 1 ' bornage en début de document
      l = i + nbPhrasesAprès ' bornage en fin de document
      If l > doc.Sentences.count Then l = doc.Sentences.count
      For ic = k To l
        doc.Sentences(ic).Copy
        ND.Activate
        Selection.EndKey Unit:=wdStory, Extend:=wdMove
        Selection.Range.Paste
      Next ic
      Selection.EndKey Unit:=wdStory, Extend:=wdMove
      Selection.TypeParagraph
      j = j + 1
      cpt2 = cpt2 + 1
    End If
    Next
    MsgBox "Terminé" & vbCrLf & cpt1 & " trouvailles dans " & cpt2 & " phrases"
End Sub