读取系统字体文件名后，如何按各行对应的字体文件显示字体？

huys

如题：
　　读取系统字体文件名后，如何按各行对应的字体文件显示字体？
Sub 字体()
On Error Resume Next
    Cells.Delete
    Range("A2").Select
    Columns("A:A").ClearContents
    Dim MyName As String
    MyName = Dir("C:\Windows\Fonts\" & "*.ttf")
     Do While MyName <> ""
        [A65536].End(xlUp).Offset(1, 0) = MyName
        MyName = Dir
    Loop
    For i = 2 To [A65536].End(xlUp).Row
       Cells(i, 2) = "中华人民共和国"
       Cells(i, 3) = "1234567890"
       Rows(i).Font.Name = ""   　　　'对应的字体
    Next
    [A1] = "字体文件名"
    [B1] = "中文"
    [C1] = "数字"
     Cells.EntireColumn.AutoFit
   Range("A1").Select
End Sub


系统字体.rar (13.58 KB, 下载次数: 3)

2022-9-20 20:05 上传

点击文件名下载附件

蓝桥玄霜

字体的例子：

huys

蓝桥玄霜 发表于 2022-9-21 09:52
字体的例子：

衷心感谢！
一直得到你的帮助！

huys

蓝桥玄霜 发表于 2022-9-21 09:52
字体的例子：

运行结果没有按实际字体显示

huys

huys 发表于 2022-9-21 13:43
运行结果没有按实际字体显示

Sub 字体()
On Error Resume Next
Cells.Clear
Range("A2").Select
Columns("A:A").ClearContents
Dim MyHame As String
MyName = Dir("C:\Windows\Fonts\" & "*.*")
Do While MyName <> ""
[A65536].End(xlUp).Offset(1, 0) = MyName
MyName = Dir
Loop
For i = 2 To [A65536].End(xlUp).Row
Cells(i, 2) = "中华人民共和国1234567890"
Cells(i, 3) = "ABCDEFG1234567890"
Cells(i, 2).Resize(1, 2).Font.Name = Split(Cells(i, 1).Value, ".")(0)
Next
[A1] = "字体文件名"
[B1] = "中文"
[C1] = "数字"
Cells.EntireColumn.AutoFit
Range("A1").Select
End Sub