Hàm chuyển số thành chữ ppt

Hàm chuyển số thành chữ Đã 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 t

Hàm chuyển số thành chữ

Đã 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

Code:

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