Hàm sau giúp chuyển đổi số thành dạng chữ trong Excel Áp dụng chuyển đổi đơn vị tiền tệ, báo cáo.. Mã: Option Explicit ' Function CountValue(ByVal Target As Range, ByVal Criteria As Long, ByVal isGreater As Boolean) As Variant Dim i As Long, j As Long Dim k As Long With Target For i = 1 To .Rows.Count For j = 1 To .Columns.Count If Not IsEmpty(.Cells(i, j)) Then If isGreater Then If Val(.Cells(i, j)) >= Criteria Then k = k + 1 Else If Val(.Cells(i, j)) <= Criteria Then k = k + 1 End If End If Next Next End With CountValue = k + 1 End Function Public Function NumtoWordExl(ByVal Target As Range, Optional IsToUnicode As Boolean = False) As String Dim iStr As String, i As Long Dim retVal As String If isBigRange(Target) Then NumtoWordExl = "" GoTo tExitFunction End If ' this is a trick to keep excel doesnt set the value to somewhat like 1.22e12+19 iStr = Format(Target.Value, "#000") retVal = NumtoWord(iStr) ' Now we have to convert the result to unicode if neccessary If retVal <> "" And IsToUnicode Then retVal = ToUnicode(retVal) NumtoWordExl = retVal tExitFunction: End Function Function NumtoWord(InTxt As String) As String ' Concert any length number to word ' The mentor is: break a number to 9 characters length and do the conversion ' for the rest .... increment the billion counter ' the main function for the conversion is at anywhere in the net and I took this one from anonimity ' My onwed function work similarly - but i failed in searching for it - it dumbed... ' so take this one in replacement Dim i As Integer, j As Integer Dim OutString As String Dim ProcArr() As String ReDim ProcArr(10) While Len(InTxt) > 9 ' break the input string to group of 9 digit ProcArr(i) = Right(InTxt, 9) InTxt = Left(InTxt, Len(InTxt) - 9) i = i + 1 Wend ProcArr(i) = InTxt ReDim Preserve ProcArr(i) ' Now convert the group to value i = UBound(ProcArr) While i > 0 ' add with "w" as billion word... OutString = OutString & IIf(Val(ProcArr(i)) > 0, ReadBilGroup(ProcArr(i)) & String(i, "w"), "") i = i - 1 Wend OutString = Replace(OutString, "w", " tû") & ReadBilGroup(ProcArr(0)) NumtoWord = Trim(OutString) End Function Private Function ReadBilGroup(s As String) As String Dim l As Integer, i As Integer, j As Integer Dim dk As Boolean Dim A(11) As Integer Dim C As String ' Variant array to quick convert the number to word Dim iArr As Variant iArr = Array("kh«ng", "mét", "hai", "ba", "bèn", "n¨m", "s¸u", "b¶y", "t¸m", "chÝn") C = "" l = Len(s) ' break number to single string For i = 1 To l A(i) = CInt(Mid(s, i, 1)) Next i For i = 1 To l ' Select Case A(i) Case 1: If (i > 1 And (l - i + 1) Mod 3 = 1 And A(i - 1) > 1) Then C = C & " mèt" ElseIf ((l - i + 1) Mod 3 <> 2 And A(i) = 1) Then C = C & " mét" End If Case 5: If (i > 0 And (l - i + 1) Mod 3 = 1 And A(i - 1) <> 0) Then C = C & " l¨m" Else C = C & " n¨m" End If Case 0: If (l - i + 1) Mod 3 = 0 And (A(i + 1) <> 0 Or A(i + 2) <> 0) Then C = C & " kh«ng" If (l - i + 1) Mod 3 = 2 And A(i + 1) <> 0 Then C = C & " linh" Case Else If i = l And A(i) = 4 Then C = C & " t­" Else C = C & " " & iArr(A(i)) End If End Select If ((l - i + 1) Mod 3 = 2 And A(i) <> 0 And A(i) <> 1) Then C = C & " m­¬i" ElseIf ((l - i + 1) Mod 3 = 2 And A(i) <> 0) Then C = C & " m­êi" End If If ((l - i + 1) Mod 3 = 0 And (A(i + 1) <> 0 Or A(i + 2) <> 0)) Then C = C & " tr¨m" ElseIf (l - i + 1) Mod 3 = 0 And A(i) <> 0 Then C = C & " tr¨m" End If If ((l - i + 1) = 4) Then C = C & " ngµn" If ((l - i + 1) = 7) Then C = C & " triÖu" If ((l - i + 1) Mod 3 = 0 And A(i) = 0 And A(i + 1) = 0 And A(i + 2) = 0) Then i = i + 2 If ((l - i + 1) Mod 3 = 1) Then dk = True For j = i To l If A(j) <> 0 Then dk = False Next j End If If dk Then Exit For Next i ReadBilGroup = C End Function Private Function isBigRange(ByVal Target As Range) As Boolean On Error GoTo ErrHandler If Target.Rows.Count > 1 Or Target.Columns.Count > 1 Then isBigRange = True ErrHandler: End Function Function ToUnicode(txtString As String, Optional isReversed As Boolean = False) As String ' This function will do the conversion of text string into 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 'parse the parameter into this local variable iStr = txtString mText = txtString 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) ' 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 fExit: ToUnicode = iStr End Function
Một hàm nữa cho các bạn tham khảo, áp dụng được với font chữ tiếng việt ABC, VNI, Unicode Mã: Function DocSoVni(conso) As String s09 = Array("", " moät", " hai", " ba", " boán", " naêm", " saùu", " baûy", " taùm", " chín") lop3 = Array("", " trieäu", " nghìn", " tyû") If Trim(conso) = "" Then DocSoVni = "" ElseIf IsNumeric(conso) = True Then If conso < 0 Then dau = "aâm " Else dau = "" conso = Application.WorksheetFunction.Round(Abs(conso), 0) conso = " " & conso conso = Replace(conso, ",", "", 1) vt = InStr(1, conso, "E") If vt > 0 Then sonhan = Val(Mid(conso, vt + 1)) conso = Trim(Mid(conso, 2, vt - 2)) conso = conso & String(sonhan - Len(conso) + 1, "0") End If conso = Trim(conso) sochuso = Len(conso) Mod 9 If sochuso > 0 Then conso = String(9 - (sochuso Mod 12), "0") & conso docso = "" I = 1 lop = 1 Do n1 = Mid(conso, I, 1) n2 = Mid(conso, I + 1, 1) n3 = Mid(conso, I + 2, 1) baso = Mid(conso, I, 3) I = I + 3 If n1 & n2 & n3 = "000" Then If docso <> "" And lop = 3 And Len(conso) - I > 2 Then s123 = " tyû" Else s123 = "" Else If n1 = 0 Then If docso = "" Then s1 = "" Else s1 = " khoâng traêm" Else s1 = s09(n1) & " traêm" End If If n2 = 0 Then If s1 = "" Or n3 = 0 Then s2 = "" Else s2 = " linh" End If Else If n2 = 1 Then s2 = " möôøi" Else s2 = s09(n2) & " möôi" End If If n3 = 1 Then If n2 = 1 Or n2 = 0 Then s3 = " moät" Else s3 = " moát" ElseIf n3 = 5 And n2 <> 0 Then s3 = " laêm" Else s3 = s09(n3) End If If I > Len(conso) Then s123 = s1 & s2 & s3 Else s123 = s1 & s2 & s3 & lop3(lop) End If End If lop = lop + 1 If lop > 3 Then lop = 1 docso = docso & s123 If I > Len(conso) Then Exit Do Loop If docso = "" Then DocSoVni = "khoâng" Else DocSoVni = dau & Trim(docso) Else DocSoVni = conso End If End Function '================================== Function DocSoAbc(conso) As String s09 = Array("", " mét", " hai", " ba", " bèn", " n¨m", " s¸u", " b¶y", " t¸m", " chÝn") lop3 = Array("", " triÖu", " ngh×n", " tû", " triÖu", " ngh×n", "") If Trim(conso) = "" Then DocSoAbc = "" ElseIf IsNumeric(conso) = True Then If conso < 0 Then dau = "©m " Else dau = "" conso = Application.WorksheetFunction.Round(Abs(conso), 0) conso = " " & conso conso = Replace(conso, ",", "", 1) vt = InStr(1, conso, "E") If vt > 0 Then sonhan = Val(Mid(conso, vt + 1)) conso = Trim(Mid(conso, 2, vt - 2)) conso = conso & String(sonhan - Len(conso) + 1, "0") End If conso = Trim(conso) sochuso = Len(conso) Mod 9 If sochuso > 0 Then conso = String(9 - (sochuso Mod 12), "0") & conso docso = "" I = 1 lop = 1 Do n1 = Mid(conso, I, 1) n2 = Mid(conso, I + 1, 1) n3 = Mid(conso, I + 2, 1) baso = Mid(conso, I, 3) I = I + 3 If n1 & n2 & n3 = "000" Then If docso <> "" And lop = 3 And Len(conso) - I > 2 Then s123 = " tû" Else s123 = "" Else If n1 = 0 Then If docso = "" Then s1 = "" Else s1 = " kh«ng tr¨m" Else s1 = s09(n1) & " tr¨m" End If If n2 = 0 Then If s1 = "" Or n3 = 0 Then s2 = "" Else s2 = " linh" End If Else If n2 = 1 Then s2 = " m­êi" Else s2 = s09(n2) & " m­¬i" End If If n3 = 1 Then If n2 = 1 Or n2 = 0 Then s3 = " mét" Else s3 = " mèt" ElseIf n3 = 5 And n2 <> 0 Then s3 = " l¨m" Else s3 = s09(n3) End If If I > Len(conso) Then s123 = s1 & s2 & s3 Else s123 = s1 & s2 & s3 & lop3(lop) End If End If lop = lop + 1 If lop > 3 Then lop = 1 docso = docso & s123 If I > Len(conso) Then Exit Do Loop If docso = "" Then DocSoAbc = "kh«ng" Else DocSoAbc = dau & Trim(docso) Else DocSoAbc = conso End If End Function '=============================== Function DocSoUni(conso) As String s09 = Array("", " m" & ChrW(7897) & "t", " hai", " ba", " b" & ChrW(7889) & "n", " n" & _ ChrW(259) & "m", " s" & ChrW(225) & "u", " b" & ChrW(7843) & "y", " t" & ChrW(225) & "m", " ch" & ChrW(237) & "n") lop3 = Array("", " tri" & ChrW(7879) & "u", " ngh" & ChrW(236) & "n", " t" & ChrW(7927)) 'Stop If Trim(conso) = "" Then DocSoUni = "" ElseIf IsNumeric(conso) = True Then If conso < 0 Then dau = ChrW(226) & "m " Else dau = "" conso = Application.WorksheetFunction.Round(Abs(conso), 0) conso = " " & conso conso = Replace(conso, ",", "", 1) vt = InStr(1, conso, "E") If vt > 0 Then sonhan = Val(Mid(conso, vt + 1)) conso = Trim(Mid(conso, 2, vt - 2)) conso = conso & String(sonhan - Len(conso) + 1, "0") End If conso = Trim(conso) sochuso = Len(conso) Mod 9 If sochuso > 0 Then conso = String(9 - (sochuso Mod 12), "0") & conso docso = "" I = 1 lop = 1 Do n1 = Mid(conso, I, 1) n2 = Mid(conso, I + 1, 1) n3 = Mid(conso, I + 2, 1) baso = Mid(conso, I, 3) I = I + 3 If n1 & n2 & n3 = "000" Then If docso <> "" And lop = 3 And Len(conso) - I > 2 Then s123 = " t" & ChrW(7927) Else s123 = "" Else If n1 = 0 Then If docso = "" Then s1 = "" Else s1 = " kh" & ChrW(244) & "ng tr" & ChrW(259) & "m" Else s1 = s09(n1) & " tr" & ChrW(259) & "m" End If If n2 = 0 Then If s1 = "" Or n3 = 0 Then s2 = "" Else s2 = " linh" End If Else If n2 = 1 Then s2 = " m" & ChrW(432) & ChrW(7901) & "i" Else s2 = s09(n2) & " m" & ChrW(432) & ChrW(417) & "i" End If If n3 = 1 Then If n2 = 1 Or n2 = 0 Then s3 = " m" & ChrW(7897) & "t" Else s3 = " m" & ChrW(7889) & "t" ElseIf n3 = 5 And n2 <> 0 Then s3 = " l" & ChrW(259) & "m" Else s3 = s09(n3) End If If I > Len(conso) Then s123 = s1 & s2 & s3 Else s123 = s1 & s2 & s3 & lop3(lop) End If End If lop = lop + 1 If lop > 3 Then lop = 1 docso = docso & s123 If I > Len(conso) Then Exit Do Loop If docso = "" Then DocSoUni = "kh" & ChrW(244) & "ng" Else DocSoUni = dau & Trim(docso) Else DocSoUni = conso End If End Function
Hàm chuyển số sang chữ tiền USD Mã: Public Function USD(WhatNumber) ' Tien USD tieng Anh' Dim ToRead, NumString, Group, Word As String Dim I, J As Byte, W, X, Y, Z As Double Dim FristColum, SecondColum, ReadMetho If WhatNumber = 0 Then ToRead = "None" Else If Abs(WhatNumber) >= 1E+15 Then ToRead = "Too long number ???" Else FristColum = Array("None", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", _ "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eightteen", "nineteen") SecondColum = Array("None", "None", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety") ReadMetho = Array("None", "trillion", "billion", "million", "thousand", "dollars", "cents") If WhatNumber < 0 Then ToRead = "Minus" & Space(1) Else ToRead = Space(0) End If NumString = Format(Abs(WhatNumber), "##############0.00") NumString = Right(Space(15) & NumString, 18) For I = 1 To 6 Group = Mid(NumString, I * 3 - 2, 3) If Group <> Space(3) Then Select Case Group Case "000" If I = 5 And Abs(WhatNumber) > 1 Then Word = "dollars" & Space(1) Else Word = Space(0) End If Case ".00" Word = "only" Case Else X = Val(Left(Group, 1)) Y = Val(Mid(Group, 2, 1)) Z = Val(Right(Group, 1)) W = Val(Right(Group, 2)) If X = 0 Then Word = Space(0) Else Word = FristColum(X) & Space(1) & "hundred" & Space(1) If W > 0 And W < 21 Then Word = Word & "and" & Space(1) End If End If If I = 6 And Abs(WhatNumber) > 1 Then Word = "and" & Space(1) & Word End If If W < 20 And W > 0 Then Word = Word & FristColum(W) & Space(1) Else If W >= 20 Then Word = Word & SecondColum(Y) & Space(1) If Z > 0 Then Word = Word & FristColum(Z) & Space(1) End If End If End If Word = Word & ReadMetho(I) & Space(1) End Select ToRead = ToRead & Word End If Next I End If End If USD = UCase(Left(ToRead, 1)) & Mid(ToRead, 2) End Function Public Function VND_US(WhatNumber) ' Tien Viet tieng Anh Dim ToRead, NumString, Group, Word As String Dim I, J As Byte, W, X, Y, Z As Double Dim FristColum, SecondColum, ReadMetho If WhatNumber = 0 Then ToRead = "None" Else If Abs(WhatNumber) >= 1E+15 Then ToRead = "! Too long number ???" Else FristColum = Array("None", "one", "two", "three", "four", "five", "six", "seven", "eight", "nine", "ten", _ "eleven", "twelve", "thirteen", "fourteen", "fifteen", "sixteen", "seventeen", "eightteen", "nineteen") SecondColum = Array("None", "None", "twenty", "thirty", "forty", "fifty", "sixty", "seventy", "eighty", "ninety") ReadMetho = Array("None", "trillion", "billion", "million", "thousand", "Vietnamese dong", "xu") If WhatNumber < 0 Then ToRead = "Minus" & Space(1) Else ToRead = Space(0) End If NumString = Format(Abs(WhatNumber), "##############0.00") NumString = Right(Space(15) & NumString, 18) For I = 1 To 6 Group = Mid(NumString, I * 3 - 2, 3) If Group <> Space(3) Then Select Case Group Case "000" If I = 5 And Abs(WhatNumber) > 1 Then Word = "Vietnamese dong" & Space(1) Else Word = Space(0) End If Case ".00" Word = "only" Case Else X = Val(Left(Group, 1)) Y = Val(Mid(Group, 2, 1)) Z = Val(Right(Group, 1)) W = Val(Right(Group, 2)) If X = 0 Then Word = Space(0) Else Word = FristColum(X) & Space(1) & "hundred" & Space(1) If W > 0 And W < 21 Then Word = Word & "and" & Space(1) End If End If If I = 6 And Abs(WhatNumber) > 1 Then Word = "and" & Space(1) & Word End If If W < 20 And W > 0 Then Word = Word & FristColum(W) & Space(1) Else If W >= 20 Then Word = Word & SecondColum(Y) & Space(1) If Z > 0 Then Word = Word & FristColum(Z) & Space(1) End If End If End If Word = Word & ReadMetho(I) & Space(1) End Select ToRead = ToRead & Word End If Next I End If End If VND_US = UCase(Left(ToRead, 1)) & Mid(ToRead, 2) End Function
