Sub ExcelFontList()

Dim n As Long, i As Long

Application.ScreenUpdating = False

Columns("A:HP").Delete

With Application.CommandBars.FindControl(ID:=1728)

    For n = 1 To .ListCount

        Cells(n, 1) = .List(n)

        Cells(n, 2) = .List(n)

        Cells(n, 2).Font.Name = Cells(n, 1)

            For i = 33 To 255

            Cells(n, i - 30) = Chr(i)

            Cells(n, i - 30).Font.Name = Cells(n, 1)

            Next

    Next n

End With

Columns("A:HP").EntireColumn.AutoFit

End Sub