Excel fontları

Option Explicit

Sub GetFonts()
Dim Fonts
Dim x As Integer

x = 1

Set Fonts = Application.CommandBars.FindControl(ID:=1728)

On Error Resume Next
Do
    Cells(x + 1, 1) = Fonts.List(x)
    If Err Then Exit Do
    x = x + 1
Loop
On Error GoTo 0

Range("A1").FormulaR1C1 = "=""Font List = "" & COUNTA(R[1]C:R[" & x - 1 & "]C)"

With Range("A1")
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Font.Name = "Arial"
    .Font.FontStyle = "Bold"
    .Font.Size = 10
    .Font.ColorIndex = 5
    .Interior.ColorIndex = 15
End With

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

Set Fonts = Nothing

End Sub