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
    ' 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
    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
    ActiveWindow.FreezePanes = True
    ActiveWorkbook.Saved = True
End Sub

Users are saying about us...

  1. This will not compile due to replacement of & by HTML escaped versions.

    Cut and paste the code into VBA.
    Use search and replace for the following three items
    & &

    Brace yourself for a font avalanch.
    Click execute. :-)

  2. Double Drat!
    OK there are things in the code that start with an ampersand and end in a semi colon that need to be replaced with other things.

    You have 30 seconds.


Leave a Reply

Your email address will not be published. Required fields are marked *

You may use these HTML tags and attributes: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <strike> <strong>

Terms and Conditions of use

The applications/code on this site are distributed as is and without warranties or liability. In no event shall the owner of the copyrights, or the authors of the applications/code be liable for any loss of profit, any problems or any damage resulting from the use or evaluation of the applications/code.

Visit Us On TwitterVisit Us On FacebookVisit Us On Google PlusVisit Us On Youtube