Private Sub Worksheet_Change(ByVal Target As Range)
Dim texte$, L%, chemin$, NomDoc$, WDoc As Object, d As Object, wdc$, deb&, n&
If Intersect(Target, [D2]) Is Nothing Then Exit Sub 'cellule à adapter
texte = CStr([D2]): L = Len(texte)
If texte <> "" Then
chemin = ThisWorkbook.Path & "\" 'à adapter
NomDoc = "MonDoc.docx" 'à adapter
On Error Resume Next
Set WDoc = GetObject(chemin & NomDoc)
On Error GoTo 0
If WDoc Is Nothing Then MsgBox "Le document '" & NomDoc & " ' est introuvable...": Exit Sub
Set d = CreateObject("Scripting.Dictionary")
wdc = Replace(WDoc.Content, vbCr & Chr(7), vbCr) 'épuration nécessaire s'il y a des tableaux
deb = 1 - L
Do
deb = InStr(deb + L, wdc, texte)
If deb = 0 Then Exit Do
n = WDoc.Range(deb - 1, deb + L - 1).Information(3) '3 => wdActiveEndPageNumber
d(n) = d(n) + 1 'comptage
Loop
WDoc.Close False
'---restitution---
n = d.Count
If n Then
If FilterMode Then ShowAllData 'si la feuille est filtrée
[C5].Resize(n) = Application.Transpose(d.keys) 'Transpose est limitée à 65536 lignes
[D5].Resize(n) = Application.Transpose(d.items)
End If
End If
Range("C" & n + 5 & ":D" & Rows.Count).ClearContents 'RAZ sous le tableau
With UsedRange: End With 'actualise la barre de défilement verticale
End Sub