Tìm tên các font trong cùng 1 ô

[digita]

Trong XL, tên kiểu chử mặc định (default font name) thì được báo trong cái format toolbar trên thanh menu. Cách thứ 2 là dùng câu sau đây để báo là font nào dùng trong ô hiện hành có giá trị.

[FONT=Times New Roman][SIZE=3]MsgBox ActiveCell.Font.Name[/SIZE][/FONT]

Tuy nhiên khi trong cùng 1 ô mà có > 1 kiểu font được dùng thì câu lệnh trên không hữu hiệu. Thí dụ nha trong 1 ô tôi có ký tự ab - a có font arial còn b thì trong dạng font wingdings .

ab

Vậy ta cần thay đổi câu lệnh trên là gì để báo đúng tên các font được dùng? Xin mọi người đóng góp ý kiến. Cám ơn.

 

[anhtuan1066]

Ái chà... món này hơi bị căng à nha! sao ko tách riêng ra từng ký tự mà tính?

 

[digita]

Tôi đã tìm ra cách giải quyết bằng cách dưới đây.

[/FONT][/SIZE]
[SIZE=3][FONT=Times New Roman]For i = 1 To Len(ActiveCell)
MsgBox ActiveCell.Characters(Start:=i, Length:=1).Font.Name
Next[/FONT][/SIZE]
[SIZE=3][FONT=Times New Roman]

Cám ơn bạn Anh Tuấn & mọi người quan tâm đến câu hỏi này.

 

[anhtuan1066]

Nè... bạn nói thế thì mấy người mới học hơi bị khó hiểu à nha! Tôi nhìn vào code cũng hơi hiểu hiểu.. tuy nhiên chưa biết nó đễ làm gì... Nhưng dù có làm gì đi chăng nữa thì bạn cũng nên cho 1 ví dụ có áp dụng đoạn code này vào, lúc đó mọi người mới biết sẽ làm chuyện gì chứ!
Giúp tí dc ko? Cho trót luôn... hi.. hi...
ANH TUẤN

 

[TranNguyenDanNhi]

Tôi đã tìm ra cách giải quyết bằng cách dưới đây.

[SIZE=3][FONT=Times New Roman]For i = 1 To Len(ActiveCell)
MsgBox ActiveCell.Characters(Start:=i, Length:=1).Font.Name
Next[/FONT][/SIZE]

Cám ơn bạn Anh Tuấn & mọi người quan tâm đến câu hỏi này.

Về vòng lặp thì không nói vì đúng rồi
Tuy nhiên nếu mỗi ký tự mà phi ra một cái Msg thì . . . hơi phiền. Nếu có 100 ký tự mà phi ra 100 cái Msg thì . . . choáng
Hơn nữa nếu ở mỗi ký tự, nếu xét thấy Font của nó trùng với Font của các ký tự trước nó thì phải bỏ qua chứ???
Mong cải thiện tốt hơn!!

Cheer!

 

[digita]

OK. Theo lời yêu cầu. Đây là 2 code để báo các font name trong 1 ô. Code 1 cho biết font name từng chữ 1.

Sub ChoBietFonts()
For i = 1 To Len(ActiveCell)
msg = msg & ActiveCell.Characters(Start:=i, Length:=1).Font.Name & vbNewLine
Next
MsgBox ActiveCell.Address & vbNewLine & msg
End Sub

Nếu còn thấy choáng ngợp thì xài code 2 không báo trùng tên font.

Sub ChoBietFonts2()
'no dupes
Dim NoDupes As New Collection

[FONT=Arial][SIZE=3]On Error Resume Next
For i = 1 To Len(ActiveCell)
NoDupes.Add ActiveCell.Characters(Start:=i, Length:=1).Font.Name, CStr(ActiveCell.Characters(Start:=i, Length:=1).Font.Name)
Next[/SIZE][/FONT]
[FONT=Arial][SIZE=3]For i = 1 To NoDupes.Count - 1
        For j = i + 1 To NoDupes.Count
            If NoDupes(i) > NoDupes(j) Then
                Swap1 = NoDupes(i)
                Swap2 = NoDupes(j)
                NoDupes.Add Swap1, before:=j
                NoDupes.Add Swap2, before:=i
                NoDupes.Remove i + 1
                NoDupes.Remove j + 1
            End If
        Next j
    Next i
    For Each Item In NoDupes
        msg = msg & Item & vbNewLine
    Next Item
 
MsgBox ActiveCell.Address & vbNewLine & msg
End Sub[/SIZE][/FONT]

.

 

[Mr Okebab]

Cho em tham gia với :

Sub ChoBietFonts()
    On Error Resume Next
    Dim i1 As Integer: Dim i2 As Integer
    Dim StrF As String: Dim TenF As String
    Dim Tim As Boolean
    If Len(ActiveCell) < 1 Then Exit Sub
    For i1 = 1 To Len(ActiveCell)
        StrF = ActiveCell.Characters(Start:=i1, Length:=1).Font.Name
        If i1 > 1 Then
            For i2 = 1 To i1 - 1
                If StrF = ActiveCell.Characters(Start:=i2, Length:=1).Font.Name Then
                    Tim = True
                    Exit For
        End If: Next: End If
        If Tim = False Then TenF = TenF & IIf(i1 > 1, Chr(13), "") & " - " & StrF
        Tim = False
    Next
    MsgBox TenF
End Sub

Thân!

 

[digita]

Ái chà, code của bạn Okebab rất hay loại bỏ giá trị trùng & ngắn nữa.
Chúc mừng anh bạn có 2 sao mai rực rở.

Thân.