Option Explicit 
 
Sub ListAllFonts() 
    Dim oDoc    As Word.Document 
    Dim oTable  As Word.Table 
    Dim iCnt    As Long 
     
    If MsgBox("Do you wish to build a list?" & vbCr & _ 
    "Building a list on older systems this may take a while" & vbCr & _ 
    vbCr & "Screen may appear frozen" & vbCr & _ 
    "Please wait for the list to complete", _ 
    vbQuestion + vbYesNo, "Built Font list") = vbYes Then 
         
        Application.ScreenUpdating = False 
         
         'Create new doc to list font's
        Set oDoc = Application.Documents.Add 
         
         'Create table of 2 columns and as many rows as there are fontnames
        Set oTable = oDoc.Tables.Add(Range:=Selection.Range, _ 
        NumRows:=Application.FontNames.Count + 1, _ 
        NumColumns:=2) 
        With oTable 
             'Create table header
            With .Cell(1, 1).Range 
                .Font.Name = "Arial" 
                .Font.Bold = True 
                .InsertAfter "Font Name" 
            End With 
             
            With .Cell(1, 2).Range 
                .Font.Name = "Arial" 
                .Font.Bold = True 
                .InsertAfter "Font Example" 
            End With 
             
             'Loop through Fontnames
            For iCnt = 1 To Application.FontNames.Count 
                 'Add Fontname to cell
                With .Cell(iCnt + 1, 1).Range 
                    .Font.Name = "Arial" 
                    .Font.Size = 10 
                    .InsertAfter Application.FontNames(iCnt) 
                End With 
                 
                 'Set Font in Cell to Fontname and insert example text
                With .Cell(iCnt + 1, 2).Range 
                    .Font.Name = Application.FontNames(iCnt) 
                    .Font.Size = 10 
                    .InsertAfter "ABCDEFG 1234567890 hijklmnop" 
                End With 
            Next iCnt 
             
             'No borders and sort table Ascending
            .Borders.Enable = False 
            .Sort SortOrder:=wdSortOrderAscending 
        End With 
    End If 
End Sub