Sub PrintFontList()
Set Word = CreateObject("Word.Application")
    For Each Font In Word.FontNames
        With ActiveCell
            .Value = Font
            .Offset(0, 1).Font.Name = Font
            .Offset(0, 1).Value = "The quick brown _
            fox jumps over  the lazy dog."
        End With
        ActiveCell.Offset(1, 0).Activate
    Next
    With ActiveCell
        .EntireColumn.AutoFit
        .Offset(0, 1).EntireColumn.AutoFit
        .Sort Key1:=ActiveCell
    End With
End Sub
