- Tham gia
- 30/5/06
- Bài viết
- 1,630
- Được thích
- 17,443
- Nghề nghiệp
- Bác sĩ
Đã có rất nhiều hàm chuyển số thành chữ trên các diễn đàn, nhưng hôm nay, tôi xin giới thiệu với các bạn hàm chuyển số thành chữ hoàn chỉnh nhất của Paulsteigel trên diễn đàn Webketoan
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
