Sub rechercheEtEnvirons()
'macro écrite par m@rina
' complétée par Geo
' crée un nouveau document avec les paragraphes contantn un des mots recherchés
' ainsi que les paragraphes précèdent ou suivent ces paragraphes
Const nbParagAvant As Long = 0
Const nbParagAprès As Long = 1

Dim doc As Document, ND As Document
Dim mon_texte As String
Dim tableauMots() As String ' les mots à rechercher
Dim tableauParag() As Boolean  ' mémorise si le texte a été trouvé dans ce §
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 numParag As Long
mon_texte = InputBox("Quel(s) mot(s) voulez-vous trouver ?", "Mots séparés par une virgule")

'mon_texte = "conjoint, conjointe, conjoint(e)"
'mon_texte = "texte"

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 tableauParag(doc.Paragraphs.count + 1) ' paragraphs(0) n'existe pas
For i = 0 To UBound(tableauParag())
  tableauParag(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
        numParag = doc.Range(Start:=1, End:=Selection.End).Paragraphs.count
           ' mémorisation du paragraphe concerné, indices décalés de 1 entre  tableau / Paragraphs
        tableauParag(numParag) = 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(tableauParag)
    ' recopié des § concernés et attenants
    ' tableau (0) est ignoré car la numéotation des § commence à 1
    
    If tableauParag(i) = True Then
      Selection.EndKey Unit:=wdStory, Extend:=wdMove
      ND.Range.InsertAfter " Trouvaille " & j & "-----------------------"
      Selection.EndKey Unit:=wdStory, Extend:=wdMove
      Selection.TypeParagraph
      k = i - nbParagAvant
      If k < 1 Then k = 1 ' bornage en début de document
      l = i + nbParagAprès ' bornage en fin de document
      If l > doc.Paragraphs.count Then l = doc.Paragraphs.count
      For ic = k To l
        doc.Paragraphs(ic).Range.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 & " paragraphes"
End Sub