Option Explicit

Sub ShowInstalledFonts()
  Dim FontList
  Dim TempBar
  Dim i
  
    Set FontList = Application.CommandBars("Formatting").FindControl(ID:=1728)
    
'   If Font control is missing, create a temp CommandBar
    If FontList Is Nothing Then
        Set TempBar = Application.CommandBars.Add
        Set FontList = TempBar.Controls.Add(ID:=1728)
    End If
    
'   Put the fonts into column A
    Application.ScreenUpdating = False
    [A:A].ClearContents
    For i = 0 To FontList.ListCount - 1
        Cells(i + 1, "A") = FontList.List(i + 1)
        Cells(i + 1, "B") = "Prova di scrittura 0123456789"
        Cells(i + 1, "B").Font.Name = FontList.List(i + 1)
    Next i
    
'   Delete temp CommandBar if it exists
    On Error Resume Next
    TempBar.Delete
  Application.ScreenUpdating = True
  Set FontList = Nothing
  Set TempBar = Nothing
End Sub