Sub ListFonts()
Application.ScreenUpdating = False
Dim ListFont As Variant
With ActiveDocument.Characters
  For Each ListFont In FontNames
    With .Last
      .Font.Name = "Arial"
      .Font.Size = 12
      .Text = ListFont & Chr(11)
    End With
    With .Last
      .Font.Name = ListFont
      .InsertAfter "ABCDEFGHIJKLMNOPQRSTUVWXYZ ~!@#$%^&*()_+|<>?:{}" & Chr(11) & _
        "abcdefghijklmnopqrstuvwxyz `1234567890-=\,.;'[]" & vbCr
    End With
    With .Last
      .Font.Name = "Arial"
      .InsertAfter vbCr
    End With
  Next ListFont
End With
Application.ScreenUpdating = True
End Sub