フォント フォント総てをシートに書き出す

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit

Sub UseFont()
'****************************************
'フォント総てをシートに書き出す
'****************************************
'対象：PC内にインストールされているフォント
'抽出先：ActiveWorkbook.ActiveSheet
'2009/6/18更新
'プログラムが使用可能なフォントは 256 個という制限があります。
'[このブックで、これ以上新しいフォントは設定できません。]

Dim objcombo As CommandBarComboBox
Dim strFontName As String
Dim intFor As Integer
Dim sht As Worksheet
Dim lngThisRow As Long
Dim Mystr As String

Mystr = "Test"

Set sht = ActiveWorkbook.ActiveSheet
Set objcombo = CommandBars(4).Controls(1)

Application.ScreenUpdating = False

With sht
    .Range("a1:c65536").Clear '①
    .Range("a1").Value = "FontName" '②
End With

For intFor = 1 To objcombo.ListCount
    strFontName = objcombo.List(intFor)
        With sht
            lngThisRow = .Range("a1").CurrentRegion.Rows.Count + 1 '③
            .Range("a" & lngThisRow).Value = strFontName '④
            .Range("c" & lngThisRow).Value = Mystr '⑤
            If intFor <= 253 Then '⑦
                With .Range("c" & lngThisRow).Font '⑥
                    .Name = strFontName
                    .Size = 18
                End With
            End If
        End With
Next intFor

Application.ScreenUpdating = True

Set sht = Nothing
Set objcombo = Nothing

'以下でも可能
'.Range(.Cells(1, 1), .Cells(65536, 3)).Clear '①
'.Cells(1, 1).Value = "FontName" '②
'lngThisRow = .Cells().End(xlUp).Row + 1 '③
'.Cells(lngThisRow, 1).Value = strFontName '④
'.Cells(lngThisRow, 2).Value = Mystr '⑤
'With .Cells(lngThisRow, 3).Font '⑥
'⑦エクセル自体が使用するフォント数もあるため
End Sub

 

2000年01月01日|[VBサンプルコード]:[フォント]