VBA : parcourir les polices

Sub ListePolices()
'd'après Chip Pearson, mpep
Dim N As Integer
  Sheets.Add
  With Application.CommandBars.FindControl(ID:=1728)
    For N = 1 To .ListCount
        Cells(N, 1).Value = .List(N)
        Cells(N, 1).Font.Name = .List(N)
        Cells(N, 1).Font.Size = 12
    Next N
  End With
  Cells(1, 1).EntireColumn.AutoFit
End Sub

Option Explicit

Sub ListePolices()    'd'après Chip Pearson, mpep
    Dim N%
    ActiveWindow.DisplayGridlines = False
    With Application.CommandBars.FindControl(ID:=1728)
        Cells.Clear
        With Cells(1, 1).Resize(, 2)
            .Value = [{"Polices Disponibles", "Exemples"}]
            .Font.Bold = True
            .Interior.ColorIndex = 15
            .EntireColumn.AutoFit
            With .Borders
                .LineStyle = 1
                .Weight = 2
            End With
        End With
        For N = 1 To .ListCount
            Cells(N + 1, 1).Value = .List(N)
            Cells(N + 1, 2) = "abcdefghijklmnopqrstuvwxyz  ABCDEFGHIJKLMNOPQRSTUVWXYZ  1234567890"
            Cells(N + 1, 2).Font.Name = .List(N)
        Next N
    End With
    With Columns("A:B")
        .Font.Size = 12
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With
    Cells(1, 1).Select
End Sub