Đặt font chữ trong list ?

Chuotdong · 28/11/06

Tôi đặt Data Validation cho 1 ô theo danh sách (list) ở một sheet khác. Nhưng vì sheet chứa list dùng font chữ khác với ô Validation nên muốn chọn tên trong list rất khó nhìn. Tôi không muốn đổi font trong sheet chứa list vì là dữ liệu của người khác cập nhật. Có cách nào đổi font chữ của Excel khác với font của Win không ?
Hình minh họa:

nvson · 28/11/06

Theo tôi bạn chuyển chữ từ TCVN sang Unicode theo hàm sau:

Mã:

Public Function ToUnicode(txtString As String, Optional isReversed As Boolean = False) As String
    ' This function will do the conversion of text string into unicode
    ' Ham chuyen ma tu TCVN sang Unicode
    Dim iStr As String, repTxt As String, mText As String
    Dim i As Long, j As Long
    Dim iUnicode As Variant ' array to keep unicode char set
    Dim iTCVN As Variant ' array to keep TCVN char set
    Dim iProcList() As String ' array to keep what to convert
    
    iUnicode = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, _
        7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, _
        7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, _
        7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, _
        432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273, 193, 192, 195, _
        258, 194, 212, 416, 431, 272)
    
    iTCVN = Array(184, 181, 182, 183, 185, 168, 190, 187, 188, 189, 198, 169, 202, 199, 200, _
        201, 203, 208, 204, 206, 207, 209, 170, 213, 210, 211, 212, 214, 221, 215, 216, 220, _
        222, 227, 223, 225, 226, 228, 171, 232, 229, 230, 231, 233, 172, 237, 234, 235, 236, _
        238, 243, 239, 241, 242, 244, 173, 248, 245, 246, 247, 249, 253, 250, 251, 252, 254, _
        174, 193, 192, 195, 161, 162, 164, 165, 166, 167)
    
    'parse the parameter into this local variable
    iStr = txtString
    mText = txtString
    ' Reenlarge the array
    ReDim iProcList(1, 133)
    ' process the vowel only and covert to asc code
    For i = 1 To Len(mText)
        repTxt = Mid(mText, i, 1)
        If AscW(repTxt) > 122 Then
            iStr = Replace(iStr, repTxt, "[" & AscW(repTxt) & "]")
            mText = Replace(mText, repTxt, " ")
            ' write the processed list
            iProcList(1, j) = "[" & AscW(repTxt) & "]"
            If isReversed Then
                iProcList(0, j) = GetElementNo(AscW(repTxt), iUnicode)
            Else
                iProcList(0, j) = GetElementNo(AscW(repTxt), iTCVN)
            End If
            j = j + 1
        End If
    Next
    If j = 0 Then
        ToUnicode = txtString
        Exit Function
    End If
    ReDim Preserve iProcList(1, j - 1)
    ' now convert to unicode
    For i = 0 To UBound(iProcList, 2)
        If isReversed Then
            iStr = Replace(iStr, iProcList(1, i), ChrW(iTCVN(Val(iProcList(0, i)))))
        Else
            iStr = Replace(iStr, iProcList(1, i), ChrW(iUnicode(Val(iProcList(0, i)))))
        End If
    Next
    ToUnicode = iStr
End Function
'-------------------------------------------------------------------
Private Function GetElementNo(iTxt As Long, iObj As Variant) As String
    Dim i As Long
    For i = 0 To UBound(iObj)
        If iTxt = iObj(i) Then
            GetElementNo = CStr(i)
            Exit For
        End If
    Next
End Function

Giả sử vùng A1: A10 là chữ theo TCVN
Vùng B1:B10 có công thức là =ToUnicode(A1)
Đặt tên cho vùng B1:B10 là listUnicode
Tại một ô nào đó bạn tạo Validation và đặt Source là =listUnicode
Bạn tạo tiếp 1 hàm chuyển ngược lại từ Unicode sang TCVN.
.................

ThuNghi · 28/11/06

Bạn cho thêm code từ VNI -> Unicode luôn nhé. Cám ơn!

nvson · 28/11/06

Để chuyển từ Unicode sang TCVN thì các bạn làm ngược lại:

Mã:

Function ToTCVN(txtString As String, Optional isReversed As Boolean = False) As String
    Dim iStr As String, repTxt As String, mText As String
    Dim i As Long, j As Long
    Dim iUnicode As Variant ' array to keep unicode char set
    Dim iTCVN As Variant ' array to keep TCVN char set
    Dim iProcList() As String ' array to keep what to convert
 
    iUnicode = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, _
        7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, _
        7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, _
        7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, _
        432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273, 193, 192, 195, _
        258, 194, 212, 416, 431, 272)
 
    iTCVN = Array(184, 181, 182, 183, 185, 168, 190, 187, 188, 189, 198, 169, 202, 199, 200, _
        201, 203, 208, 204, 206, 207, 209, 170, 213, 210, 211, 212, 214, 221, 215, 216, 220, _
        222, 227, 223, 225, 226, 228, 171, 232, 229, 230, 231, 233, 172, 237, 234, 235, 236, _
        238, 243, 239, 241, 242, 244, 173, 248, 245, 246, 247, 249, 253, 250, 251, 252, 254, _
        174, 193, 192, 195, 161, 162, 164, 165, 166, 167)
 
    iStr = txtString
    mText = txtString
    ReDim iProcList(1, 133)
    For i = 1 To Len(mText)
        repTxt = Mid(mText, i, 1)
        If AscW(repTxt) > 122 Then
            iStr = Replace(iStr, repTxt, "[" & AscW(repTxt) & "]")
            mText = Replace(mText, repTxt, " ")
            iProcList(1, j) = "[" & AscW(repTxt) & "]"
            If isReversed Then
                iProcList(0, j) = GetElementNo(AscW(repTxt), iTCVN)
            Else
                iProcList(0, j) = GetElementNo(AscW(repTxt), iUnicode)
            End If
            j = j + 1
        End If
    Next
    If j = 0 Then
        ToTCVN = txtString
        Exit Function
    End If
    ReDim Preserve iProcList(1, j - 1)
    For i = 0 To UBound(iProcList, 2)
        If isReversed Then
            iStr = Replace(iStr, iProcList(1, i), ChrW(iUnicode(Val(iProcList(0, i)))))
        Else
            iStr = Replace(iStr, iProcList(1, i), ChrW(iTCVN(Val(iProcList(0, i)))))
        End If
    Next
    ToTCVN = iStr
End Function

PhanTuHuong · 28/11/06

Sơn ơi, thế còn chuyển font TCVN sang Unicode trong Word thì làm cách nào vậy?

nvson · 29/11/06

Chuyển font TCVN sang Unicode trong MS Word

PhanTuHuong đã viết:
Sơn ơi, thế còn chuyển font TCVN sang Unicode trong Word thì làm cách nào vậy?

Em cũng đang viết chương trình chuyển đổi font ở Word, nhưng chưa xong (phần Convert thì xong rồi, nhưng vẫn còn thiếu chút định dạng nữa - vì em muốn định dạng lại đúng như định dạng ban đầu)
Đây là đoạn mã em chuyển từ TCVN sang Unicode (chưa xong, phần chữ hoa chưa được như ý muốn...)

Mã:

Function ToUnicode(txtString As String, Optional isReversed As Boolean = False) As String
    ' This function will do the conversion of text string into unicode
    ' Ham chuyen ma tu TCVN sang Unicode
    Dim iStr As String, repTxt As String, mText As String
    Dim i As Long, j As Long
    Dim iUnicode As Variant ' array to keep unicode char set
    Dim iTCVN As Variant ' array to keep TCVN char set
    Dim iProcList() As String ' array to keep what to convert
    
    iUnicode = Array(225, 224, 7843, 227, 7841, 259, 7855, 7857, 7859, 7861, 7863, 226, _
        7845, 7847, 7849, 7851, 7853, 233, 232, 7867, 7869, 7865, 234, 7871, 7873, 7875, _
        7877, 7879, 237, 236, 7881, 297, 7883, 243, 242, 7887, 245, 7885, 244, 7889, 7891, _
        7893, 7895, 7897, 417, 7899, 7901, 7903, 7905, 7907, 250, 249, 7911, 361, 7909, _
        432, 7913, 7915, 7917, 7919, 7921, 253, 7923, 7927, 7929, 7925, 273, 193, 192, 195, _
        258, 194, 212, 416, 431, 272)
    
    iTCVN = Array(184, 181, 182, 183, 185, 168, 190, 187, 188, 189, 198, 169, 202, 199, 200, _
        201, 203, 208, 204, 206, 207, 209, 170, 213, 210, 211, 212, 214, 221, 215, 216, 220, _
        222, 227, 223, 225, 226, 228, 171, 232, 229, 230, 231, 233, 172, 237, 234, 235, 236, _
        238, 243, 239, 241, 242, 244, 173, 248, 245, 246, 247, 249, 253, 250, 251, 252, 254, _
        174, 193, 192, 195, 161, 162, 164, 165, 166, 167)
    
    'parse the parameter into this local variable
    iStr = txtString
    mText = txtString
    ' Reenlarge the array
    ReDim iProcList(1, 133)
    ' process the vowel only and covert to asc code
    For i = 1 To Len(mText)
        repTxt = Mid(mText, i, 1)
        If AscW(repTxt) > 122 Then
            iStr = Replace(iStr, repTxt, "[" & AscW(repTxt) & "]")
            mText = Replace(mText, repTxt, " ")
            ' write the processed list
            iProcList(1, j) = "[" & AscW(repTxt) & "]"
            If isReversed Then
                iProcList(0, j) = GetElementNo(AscW(repTxt), iUnicode)
            Else
                iProcList(0, j) = GetElementNo(AscW(repTxt), iTCVN)
            End If
            j = j + 1
        End If
    Next
    If j = 0 Then
        ToUnicode = txtString
        Exit Function
    End If
    ReDim Preserve iProcList(1, j - 1)
    ' now convert to unicode
    For i = 0 To UBound(iProcList, 2)
        If isReversed Then
            iStr = Replace(iStr, iProcList(1, i), ChrW(iTCVN(Val(iProcList(0, i)))))
        Else
            iStr = Replace(iStr, iProcList(1, i), ChrW(iUnicode(Val(iProcList(0, i)))))
        End If
    Next
    ToUnicode = iStr
End Function
Private Function GetElementNo(iTxt As Long, iObj As Variant) As String
    Dim i As Long
    For i = 0 To UBound(iObj)
        If iTxt = iObj(i) Then
            GetElementNo = CStr(i)
            Exit For
        End If
    Next
End Function
Public Sub ChuyenUnicode()
On Error Resume Next
Dim strText1 As String
Dim strText2 As String
Dim i As Integer
Dim n As Integer
Dim pa() As ParagraphFormat
Dim Fonts1() As String
n = Selection.Paragraphs.Count
ReDim pa(1 To n) As ParagraphFormat
ReDim Fonts1(1 To n) As String
For i = 1 To Selection.Paragraphs.Count
    Set pa(i) = Selection.Paragraphs(i).Format
Next
For i = 1 To Selection.Paragraphs.Count
    Fonts1(i) = Selection.Paragraphs(i).Range.Font.Name
    Fonts1(i) = Right(Fonts1(i), 1)
Next
strText1 = Selection
strText2 = ToUnicode(strText1)
Documents.Add DocumentType:=wdNewBlankDocument
Selection.TypeText Text:=strText2
Selection.WholeStory
For i = 1 To Selection.Paragraphs.Count
    Selection.Paragraphs(i).Format = pa(i)
Next
Selection.Font.Name = "Times New Roman"
For i = 1 To Selection.Paragraphs.Count
    If Fonts1(i) = "H" Then
        Selection.Paragraphs(i).Range.Case = wdUpperCase
    End If
Next
End Sub

Cách sử dụng:
Chọn một đoạn văn bản trong MS Word, rồi chạy Macro "ChuyenUnicode"

CPH · 29/11/06

PhanTuHuong đã viết:
Sơn ơi, thế còn chuyển font TCVN sang Unicode trong Word thì làm cách nào vậy?

Tôi thấy cái này hay hay, không biết có đáp ứng nhu cầu của các bạn ko?

Hic, có 445KB mà không up lên đc, tui có cái convert file word; excel; power point; Rich text; HTML; Text từ unicode thành TCVN, vì ko up lên đc nên ai cần thì liên hệ qua cuongphuchung@yahoo.com tui gửi cho.

Thien · 29/11/06

Sao không ai dùng cái ni cho đơn giản & chính xác rứa.

jianguo · 26/3/10

Thien đã viết:
Sao không ai dùng cái ni cho đơn giản & chính xác rứa.

Cảm ơn bạn Thiện nhiều nhé, Mình đã load về và dùng thử và thấy đúng như vậy. Chuyển Font rất tốt và quan trong nhất là ko bị mất đường link công thức. Đây sẽ là file lựa chọn số 1.

Đặt font chữ trong list ?

Chuotdong

Thành viên thường trực

nvson

Geotechnics

ThuNghi

Hãy cho rồi sẽ nhận!

nvson

Geotechnics

PhanTuHuong

VBA & VB.NET for Excel & AutoCad

nvson

Geotechnics

CPH

Thành viên chính thức

Thien

Thành viên thường trực

File đính kèm

jianguo

Thành viên mới

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian