Sub ShowInstalledFonts()
    Dim FontList As CommandBarControl
    Dim TempBar As CommandBar
    Dim i As Integer
    
    Set FontList = Application.CommandBars("Formatting"). _
       FindControl(ID:= 1728 )
    
'   Если элемент управления Font удален, то создается временная панель управления CommandBar
    If FontList Is Nothing Then
        Set TempBar = Application.CommandBars.Add
        Set FontList = TempBar.Controls.Add(ID:= 1728 )
    End If
    
'   Занесение списка шрифтов в столбец A
    Range("A:A").ClearContents
    For i =  0  To FontList.ListCount -  1 
        Cells(i +  1 ,  1 ) = FontList.List(i +  1 )
    Next i
    
'   Удаление временной панели управления CommandBar, если она создавалась
    On Error Resume Next
    TempBar.Delete
End Sub