Sub ListFonts()
Dim ListFont as Variant
Application.ScreenUpdating = False
For Each ListFont in Fontnames
  With Selection
    .Font.Name = "Arial"
    .Font.Size = 12
    .TypeText ListFont
    .TypeText Text := Chr(11)
    .Font.Name = ListFont
    .TypeText "ABCDEFGHIJKLMNOPQRSTUVWXYZ ~!@#$%^&*()_+|<>?:{}"
    .TypeText Text := Chr(11)
    .TypeText "abcdefghijklmnopqrstuvwxyz '1234567890-=\,.;'[]"
    .TypeText Text := Chr(11)
    .InsertParagraphAfter
    .Movedown Unit := wdParagraph, Count := 1, Extend := wdMove
  End With
Next ListFont
Selection.WholeStory
Selection.Sort
Selection.HomeKey Unit := wdStory
End sub