Avec une macro :
Sub surlignage()
'macro écrite par m@rina
Dim trad As String, Liste As String, ND As Document
Application.ScreenUpdating = False
Selection.HomeKey Unit:=wdStory
'Recherche de tous les mots surlignés
Do
Selection.Find.ClearFormatting
With Selection.Find
.Highlight = True
.Execute
End With
If Selection.Find.Found Then
trad = Selection.Text
If InStr(Liste, trad) = 0 Then
Liste = Liste & trad & vbCr
End If
End If
Loop Until Not Selection.Find.Found
'On crée le nouveau doc et on y insère les textes trouvés
Set ND = Documents.Add
Selection.TypeText Text:=Liste
End Sub