excelフォント一覧表

Sub font()
'フォント名と見本一覧を作成
    Cells(1, 1) = "フォント名"
    Cells(1, 2) = "数字見本"
    Cells(1, 3) = "小文字見本"
    Cells(1, 4) = "大文字見本"
   
    Dim i As Integer
    Dim str As String
    Dim obj As Object
    str = "0123456789"
    str2 = "abcdefghijklmnopqrstuvwxyz"
    str3 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    Set obj = Application.CommandBars("Formatting"). _
        Controls.Item(1)
   
    For i = 1 To obj.ListCount
        Cells(i + 1, 1) = obj.List(i)
        Cells(i + 1, 2) = str
        Cells(i + 1, 3) = str2
        Cells(i + 1, 4) = str3
        Cells(i + 1, 2).font.Name = obj.List(i)
        Cells(i + 1, 3).font.Name = obj.List(i)
        Cells(i + 1, 4).font.Name = obj.List(i)
    Next i
   
End Sub