Sub Word()
Dim chemin$, d As Object, i&, a, Wapp As Object, Wdoc As Object
chemin = ThisWorkbook.Path & "\" 'à adapter
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare
With [C2].CurrentRegion
'---liste des noms sans doublon---
For i = 2 To .Rows.Count
d(.Cells(i, 1).Value) = ""
Next
If d.Count = 0 Then Exit Sub
a = d.keys
'---filtrage et création des fichiers Word---
Application.ScreenUpdating = False
.Columns(1).Hidden = True 'masque
For i = 0 To UBound(a)
.AutoFilter 1, a(i)
If Wapp Is Nothing Then Set Wapp = CreateObject("Word.Application"): Wapp.Visible = True
Set Wdoc = Wapp.Documents.Add
Wdoc.Content = a(i) & vbLf
Wdoc.Paragraphs(1).Range.Font.Bold = True 'gras
Wdoc.Paragraphs(1).Range.Font.Underline = 1 'wdUnderlineSingle
.Copy 'copier
Wdoc.Paragraphs(2).Range.Paste 'coller
Wdoc.Content.ParagraphFormat.SpaceBefore = 6 'cadrage vertical
Wdoc.SaveAs chemin & a(i) & ".docx"
Application.CutCopyMode = 0
Next
.Columns(1).Hidden = False 'affiche
If .Parent.FilterMode Then .Parent.ShowAllData 'RAZ
Wapp.Quit 'ferme Word
End With
End Sub