Display all installed fonts (Excel) using VBA in Microsoft Excel

The macro below will display a list of all installed fonts. Note! If you have many fonts installed,
the macro may stop responding because of lack of available memory. If this happens you can try the
sample for Word later in this document.

Sub ShowInstalledFonts()
Const StartRow As Integer = 4
Dim FontNamesCtrl As CommandBarControl, FontCmdBar As CommandBar, tFormula As String
Dim fontName As String, i As Long, fontCount As Long, fontSize As Integer
    fontSize = 0
    fontSize = Application.InputBox("Enter Sample Font Size Between 8 And 30", _
         "Select Sample Font Size", 12, , , , , 1)
    If fontSize = 0 Then Exit Sub
    If fontSize < 8 Then fontSize = 8
    If fontSize > 30 Then fontSize = 30
    Set FontNamesCtrl = Application.CommandBars("Formatting").FindControl(ID:=1728)
    ' If Font control is missing, create a temp CommandBar
    If FontNamesCtrl Is Nothing Then
        Set FontCmdBar = Application.CommandBars.Add("TempFontNamesCtrl", _
            msoBarFloating, False, True)
        Set FontNamesCtrl = FontCmdBar.Controls.Add(ID:=1728)
    End If
    Application.ScreenUpdating = False
    fontCount = FontNamesCtrl.ListCount
    Workbooks.Add
    ' list font names in column A and font example in column B
    For i = 0 To FontNamesCtrl.ListCount - 1
        fontName = FontNamesCtrl.List(i + 1)
        Application.StatusBar = "Listing font " & _
            Format(i / (fontCount - 1), "0 %") & " " & _
            fontName & "..."
        Cells(i + StartRow, 1).Formula = fontName
        With Cells(i + StartRow, 2)
            tFormula = "abcdefghijklmnopqrstuvwxyz"
            If Application.International(xlCountrySetting) = 47 Then
                tFormula = tFormula & "æøå"
            End If
            tFormula = tFormula & UCase(tFormula)
            tFormula = tFormula & "1234567890"
            .Formula = tFormula
            .Font.Name = fontName
        End With
    Next i
    Application.StatusBar = False
    If Not FontCmdBar Is Nothing Then FontCmdBar.Delete
    Set FontCmdBar = Nothing
    Set FontNamesCtrl = Nothing
    ' add heading
    Columns(1).AutoFit
    With Range("A1")
        .Formula = "Installed fonts:"
        .Font.Bold = True
        .Font.Size = 14
    End With
    With Range("A3")
        .Formula = "Font Name:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    With Range("B3")
        .Formula = "Font Example:"
        .Font.Bold = True
        .Font.Size = 12
    End With
    With Range("B" & StartRow & ":B" & _
        StartRow + fontCount)
        .Font.Size = fontSize
    End With
    With Range("A" & StartRow & ":B" & _
        StartRow + fontCount)
        .VerticalAlignment = xlVAlignCenter
    End With
    Range("A4").Select
    ActiveWindow.FreezePanes = True
    Range("A2").Select
    ActiveWorkbook.Saved = True
End Sub