Here’s how to make a list of all the available fonts on a computer by making a table in Word complete with sample text using each font.
It makes a Word table of all the fonts, including sample text like this.
VBA features on show
The code is fairly straight-forward and a simple example of some standard VBA features.
- Make a new blank document
Documents.Add DocumentType:=wdNewBlankDocument
- Make a new table
Set tbl = ActiveDocument.Tables.Add(<range>, <rows>, <columns>)
- Insert text with the
.textproperty - Apply formatting using
With .. End With.
Most computers have a lot of installed fonts so the code can take many minutes and lockup Word. For testing, use the alternative line starting “Set tbl = ActiveDocument...." which only shows the first 20 fonts (or however many you want). There’s no need to change the For loop starting line.
Screen updating
Slightly speed up the code by stopping the screen updating. Add Application.ScreenUpdating = False near the start and crucially Application.ScreenUpdating = True at the end.
Easily install an Office VBA macro
Copy VBA Macros between Microsoft Word documents
Easily learn and make Office VBA with ChatGPT
This code lists all fonts on the computer. We have other code to show all fonts in a single document.
Copy the code
Sub ListInstalledFontsInTable()
Dim i As Long
Dim rng As Range
Dim tbl As Table
' Create a new document
Documents.Add DocumentType:=wdNewBlankDocument
' Set a range for the new table
Set rng = ActiveDocument.Range(0, 0)
' Create a table with as many rows as there are installed fonts
' this line lists all fonts and can take a long time to run
Set tbl = ActiveDocument.Tables.Add(rng, Application.FontNames.Count, 3)
' use this for testing, it's faster. Limits the table to first 20 fonts.
'Set tbl = ActiveDocument.Tables.Add(rng, 20, 3)
' Set the headers
tbl.Cell(1, 1).Range.Text = "Number"
tbl.Cell(1, 2).Range.Text = "Name"
tbl.Cell(1, 3).Range.Text = "Sample"
' Populate the table
For i = 1 To Application.FontNames.Count
tbl.Cell(i + 1, 1).Range.Text = i
tbl.Cell(i + 1, 2).Range.Text = Application.FontNames(i)
With tbl.Cell(i + 1, 3).Range
' change this line to whatever sample text you want.
.Text = "ABCDEFGHIJKLMNOPQRSTUVWXYZ 1234567890"
With .Font
.Name = Application.FontNames(i)
.Size = 12
.Bold = False
.Underline = False
.Italic = False
End With
End With
Next i
' Autofit the table to contents
tbl.AutoFitBehavior wdAutoFitContent
End Sub
Copying the code above should work OK in Edge/Chrome browsers.
With Firefox, we’re told there are problems, probably related to the end of line breaks. Make sure that each code line ends with a full line break, if necessary replace each end of line with a press of the ‘Enter’ key.
