Hỏi về hàm đổi số thành chữ (5)

Tôi muốn xin cái hàm viết trên văn bản hay gì đó để chuyển số thành chữ hay dùng trong Excel và Word. Bạn nào có sẵn cho tôi xin với.

Lên mạng tìm cũng thấy nhưng mang về edit nói cứ báo lỗi. Một số trang thì cứ đòi làm thành viên mới cho down. Xin chân thành cảm ơn!

Quang Sy

Hồi âm xin gửi về: vitinh@vnexpress.net

Hồi âm:

Mình tình cờ có được 1 mẫu file Excel của khách hàng làm phiếu thu và phiếu chi có phần chuyển số tiền thành chữ! Theo mình biết thì mỗi con số có 1 hàm riêng ví dụ 500.000 đồng sẽ gồm 7 lệnh trong đó 6 lệnh chuyển mỗi ký tự thành chữ và có 1 hàm nữa kết hợp tất cả các chữ số đó lại thành “năm trăm ngàn đồng chẵn”. Hãy e-mail theo địa chỉ: hongbaongan@gmail.com, mình sẽ gửi cho bạn!

Hong Bao Ngan

Chào bạn, tặng bạn chương trình dịch số để sử dụng. Chúc bạn thành công.

Function DLT(sotien)

If sotien = 0 Then

ketqua = "Khoâng ñoàng"

Else

If Abs(sotien) > 999999999999.99 Then

ketqua = "Soá quaù lôùn"

Else

If sotien < 0 Then

ketqua = "Tröø"

Else

ketqua = Space(0)

End If

B = Space(1)

tien = Format(Abs(sotien), "###########0.00")

tien = Right(Space(12) + tien, 15)

chudoc = Space(0)

chudoc = chudoc + "traêm möôi tyû traêm möôi trieäu traêm möôi ngaøn traêm möôi ñoàng traêm möôi xu"

chuso = Space(0)

chuso = chuso + "moät hai ba boán naêm saùu baûy taùm chín "

For i = 1 To 5

baso = Mid(tien, i * 3 - 2, 3)

If baso <> Space(3) Then

Select Case baso

Case "000"

If i = 4 Then

chu = "ñoàng"

Else

chu = Space(0)

End If

Case ".00"

chu = " chaün"

Case Else

so1 = Left(baso, 1)

so2 = Mid(baso, 2, 1)

so3 = Right(baso, 1)

chu = Space(0)

For j = 1 To 3

dich = Space(0)

s = Val(Mid(baso, j, 1))

If s > 0 Then

'------------------------

dich = Trim(Mid(chuso, s * 5 - 4, 5)) + B + Trim(Mid(chudoc, (i - 1) * 18 + j * 6 - 5, 6)) + Space(1)

End If

Select Case j

Case Is = 2 And s = 1

dich = "möôøi" + Space(1)

Case Is = 3 And s = 0 And baso <> Space(2) + "0"

dich = Trim(Mid(chudoc, (i - 1) * 18 + j * 6 - 5, 6)) + Space(1)

Case Is = 3 And s = 5 And so2 <> Space(1) And so2 <> "0"

dich = "l" + Mid(dich, 2)

Case 2 And s = 0 And so3 <> "0"

If (so1 >= "1" And so1 <= "9") Or (so1 = "0" And i = 4) Then

dich = "leû" + Space(1)

End If

End Select

chu = chu + dich

Next j

End Select

vitri = InStr(1, chu, "möôi moät", 1)

If vitri > 0 Then

chu = Mid(chu, vitri, 9)

End If

ketqua = ketqua + chu

End If

Next i

End If

End If

DLT = UCase(Left(ketqua, 1)) + Mid(ketqua, 2)

End Function

Do Lenh Tien

Do VBA không hỗ trợ Unicode trực tiếp nên phải dùng gián tiếp. Nhớ enable macro. Có thể nhấn Alt+F11 để xem code

Private wordsArr(9, 3) As String

Private Sub WordInitialize()

'Cach dem so

wordsArr(0, 0) = "m" & ChrW(7897) & "t": wordsArr(1, 0) = "hai": wordsArr(2, 0) = "ba"

wordsArr(3, 0) = "b" & ChrW(7889) & "n": wordsArr(4, 0) = "n" & ChrW(259) & "m": wordsArr(5, 0) = "s" & ChrW(225) & "u"

wordsArr(6, 0) = "b" & ChrW(7843) & "y": wordsArr(7, 0) = "t" & ChrW(225) & "m": wordsArr(8, 0) = "ch" & ChrW(237) & "n"

wordsArr(9, 0) = "m" & ChrW(432) & ChrW(7901) & "i"

wordsArr(0, 1) = "tr" & ChrW(259) & "m": wordsArr(1, 1) = "ch" & ChrW(7909) & "c": wordsArr(2, 1) = "hai m" & ChrW(432) & ChrW(417) & "i"

wordsArr(3, 1) = "ba m" & ChrW(432) & ChrW(417) & "i": wordsArr(4, 1) = "b" & ChrW(7889) & "n m" & ChrW(432) & ChrW(417) & "i": wordsArr(5, 1) = "n" & ChrW(259) & "m m" & ChrW(432) & ChrW(417) & "i"

wordsArr(6, 1) = "s" & ChrW(225) & "u m" & ChrW(432) & ChrW(417) & "i": wordsArr(7, 1) = "b" & ChrW(7843) & "y m" & ChrW(432) & ChrW(417) & "i": wordsArr(8, 1) = "t" & ChrW(225) & "m m" & ChrW(432) & ChrW(417) & "i"

wordsArr(9, 1) = "ch" & ChrW(237) & "n m" & ChrW(432) & ChrW(417) & "i"

wordsArr(0, 3) = "m" & ChrW(432) & ChrW(7901) & "i": wordsArr(1, 3) = "m" & ChrW(432) & ChrW(7901) & "i m" & ChrW(7897) & "t": wordsArr(2, 3) = "m" & ChrW(432) & ChrW(7901) & "i hai"

wordsArr(3, 3) = "m" & ChrW(432) & ChrW(7901) & "i ba": wordsArr(4, 3) = "m" & ChrW(432) & ChrW(7901) & "i b" & ChrW(7889) & "n": wordsArr(5, 3) = "m" & ChrW(432) & ChrW(7901) & "i l" & ChrW(259) & "m"

wordsArr(6, 3) = "m" & ChrW(432) & ChrW(7901) & "i s" & ChrW(225) & "u": wordsArr(7, 3) = "m" & ChrW(432) & ChrW(7901) & "i b" & ChrW(7843) & "y": wordsArr(8, 3) = "m" & ChrW(432) & ChrW(7901) & "i t" & ChrW(225) & "m"

wordsArr(9, 3) = "m" & ChrW(432) & ChrW(7901) & "i ch" & ChrW(237) & "n"

End Sub

Public Function ToWords(NumberStr As String) As String

Call WordInitialize

Dim z As String, x As String, Temp As String, c As String, d As String

Dim a As Integer, b As Integer, i As Integer

'remove redundant spaces

NumberStr = Trim(NumberStr)

a = Len(NumberStr)

Temp = NumberStr

If Val(NumberStr) = 0 Then

ToWords = "zero!"

Exit Function

End If

While ((a Mod 3) <> 0)

Temp = "0" & Temp

a = Len(Temp)

Wend

NumberStr = Temp

For i = a - 2 To 1 Step -3

b = b + 1

Temp = Mid(NumberStr, i, 3)

z = ""

' "Intelligent" routines

'------------------------

'Hang tram

If Temp <> "000" Then

c = Left(Temp, 1)

If c <> "0" Then

z = " " & wordsArr(Val(c) - 1, 0) & " tr" & ChrW(259) & "m"

Else

If (b = 1) And (a > 3) Then z = " " & " kh" & ChrW(244) & "ng tr" & ChrW(259) & "m"

End If

'Hang chuc

c = Mid(Temp, 2, 1)

d = Right(Temp, 1)

If c <> "0" Then

If c <> "1" Then

z = z & " " & wordsArr(Val(c), 1)

Else

z = z & " " & wordsArr(Val(Right(Temp, 2)) - 10, 3)

End If

Else

If b >= 1 And d <> "0" Then z = z & " l" & ChrW(7867)

End If

If d <> "0" And Mid(Temp, 2, 1) <> "1" Then

If c <> 0 Then

Select Case d

Case 1

z = z & " m" & ChrW(7897) & "t"

Case 4

z = z & " t" & ChrW(432) & ""

Case 5

z = z & " l" & ChrW(259) & "m"

Case Else

z = z & " " & wordsArr(Val(Right(Temp, 1)) - 1, 0)

End Select

Else

z = z & " " & wordsArr(Val(Right(Temp, 1)) - 1, 0)

End If

End If

End If

'------------------------

If z <> "" Then

Select Case b

Case 1:

x = z

Case 2:

x = z & " ng" & ChrW(224) & "n" & x

Case 3:

x = z & " tri" & ChrW(7879) & "u" & x

Case 4:

x = z & " t" & ChrW(7927) & x

Case 5:

x = z & "NA" & x

Case Else:

Exit Function

'you can easily add more range

'like Case 6: can be "zillion"? :) (whatever)

End Select

End If

Next

x = Trim(x)

If Left(x, 1) = "l" Then x = Right(x, Len(x) - 3)

'x = UCase(Left(x, 1)) & Right(x, Len(x) - 1)

ToWords = UCase(Left(x, 1))

ToWords = ToWords & Right(x, Len(x) - 1)

End Function

Vo Dai Ngoc

Hàm đổi số thành chữ =text (khong can doi dinh dang) trong đó: ô cần đổi là ô chứa giá trị số định dạng: là dạng số cần thể hiện ra VD: ô cần đổi chứa giá trị số là: 12345 nếu muốn đổi sang gíá trị text thì có thể sử dụng định dạng: #### hoặc ####,### hoặc dd/mm/yyyy nếu sử dụng định dạng ##### thì giá trị text nhận đuợc là :12345 không tin thì sử dụng hàm istext xem có phải giá trị đó là text hay không.

Le Manh Hung

Như ta đã biết trong các giấy tờ kế toán thường ghi bằng số và bằng chữ.
Đây là hàm giúp bạn thực hiện việc này dễ dàng với các bảng mã VNI, ABC, Unicode. Để tiện cho mọi người sử dụng tôi xin giới thiệu sơ qua cách sử dụng hàm trong Excel:

Bước 1: Mở trình soạn thảo VBA
- Vào Tools>Macro>Visual Basic Editor
=> Thêm 1 module
- Vào Insert>Module
=> Trong module1
Copy code dưới đây vào module1:

Bước 2: Quay lại sheet trong Excel:
- Nhập A1= 123.456.789.105,00
- A2= NumberToText(A1)
= Một trăm hai mươi ba tỷ, bốn trăm năm mươi sáu triệu, bảy trăm tám mươi chín nghìn, một trăm lẻ năm

*Ghi chú:
A2 = NumberToText(A1,0) 'Hàm định dạng Font Windows-VNI (Vni-Times)
A2=NumberToText(A1,1) 'Hàm định dạng Font ABC (VNTimes)
A2=NumberToText(A1,2) 'Hàm định dạng Font Unicode (Tahoma)

Nếu bạn nào muốn chỉnh sửa theo nhu cầu xin Email:
phvthanh@gmail.com mình sẽ chỉnh sửa lại.

Sau đây là đoạn CODE:

Public Enum Font_Codes
Font_VNI = 0
Font_ABC = 1
Font_Unicode = 2
End Enum

Public Function NumberToText(ByVal varVal As Variant, Optional ByVal Code As Font_Codes) As String
On Error GoTo Pro_Err
Static sDVs(0 To 15) As String
Static sDVNs(0 To 9) As String
Dim strErr As String
Dim sTens As String
Dim sHundred As String
Dim strDong As String
Dim strDolla As String
Dim sVal As String
Dim iVal As Integer
Dim i As Integer
Dim iCol As Integer
Dim iChar As Integer
Dim sTemp As String
Dim iScan As Integer
Dim strCurrency As String

Select Case Code
Case 0
sDVs(0) = " khoâng"
sDVs(1) = " moät"
sDVs(2) = " hai"
sDVs(3) = " ba"
sDVs(4) = " boán"
sDVs(5) = " naêm"
sDVs(6) = " saùu"
sDVs(7) = " baûy"
sDVs(8) = " taùm"
sDVs(9) = " chín"
sDVs(10) = " möôøi"
sDVs(11) = " moát"
sDVs(12) = " leû"
sDVs(13) = ""
sDVs(14) = " tö"
sDVs(15) = " laêm"

sDVNs(0) = ""
sDVNs(1) = " nghìn,"
sDVNs(2) = " trieäu,"
sDVNs(3) = " tyû,"
sDVNs(4) = " nghìn tyû,"
sDVNs(5) = " trieäu tyû,"
sDVNs(6) = " tyû tyû,"
sDVNs(7) = " nghìn tyû tyû,"
sDVNs(8) = " trieäu tyû tyû,"
sDVNs(9) = " tyû tyû tyû,"

strErr = " Loãi nhaäp!"
strEven = " chaün"
sHundred = " traêm"
sTens = " möôi"
strDong = " ñoàng"
strDolla = " ñoâ la"

Case 1
sDVs(0) = " kh«ng"
sDVs(1) = " mét"
sDVs(2) = " hai"
sDVs(3) = " ba"
sDVs(4) = " bèn"
sDVs(5) = " n¨m"
sDVs(6) = " s¸u"
sDVs(7) = " b¶y"
sDVs(8) = " t¸m"
sDVs(9) = " chÝn"
sDVs(10) = " m­êi"
sDVs(11) = " mèt"
sDVs(12) = " lÎ"
sDVs(13) = ""
sDVs(14) = " t­"
sDVs(15) = " l¨m"

sDVNs(0) = ""
sDVNs(1) = " ngh×n,"
sDVNs(2) = " triÖu,"
sDVNs(3) = " tû,"
sDVNs(4) = " ngh×n tû,"
sDVNs(5) = " triÖu tû,"
sDVNs(6) = " tû tû,"
sDVNs(7) = " ngh×n tû tû,"
sDVNs(8) = " triÖu tû tû,"
sDVNs(9) = " tû tû tû,"

strErr = " Lçi nhËp!"
strEven = " ch½n"
sHundred = " tr¨m"
sTens = " m­¬i"
strDong = " ®ång"
strDolla = " ®« la"

Case 2
sDVs(0) = " kh" & ChrW$(&HF4) & "ng"
sDVs(1) = " m" & ChrW$(&H1ED9) & "t"
sDVs(2) = " hai"
sDVs(3) = " ba"
sDVs(4) = " b" & ChrW$(&H1ED1) & "n"
sDVs(5) = " n" & ChrW$(&H103) & "m"
sDVs(6) = " s" & ChrW$(&HE1) & "u"
sDVs(7) = " b" & ChrW$(&H1EA3) & "y"
sDVs(8) = " t" & ChrW$(&HE1) & "m"
sDVs(9) = " ch" & ChrW$(&HED) & "n"
sDVs(10) = " m" & ChrW$(&H1B0) & ChrW$(&H1EDD) & "i"
sDVs(11) = " m" & ChrW$(&H1ED1) & "t"
sDVs(12) = " l" & ChrW$(&H1EBB)
sDVs(13) = ""
sDVs(14) = " t" & ChrW$(&H1B0)
sDVs(15) = " l" & ChrW$(&H103) & "m"

sDVNs(0) = ""
sDVNs(1) = " ngh" & ChrW$(&HEC) & "n,"
sDVNs(2) = " tri" & ChrW$(&H1EC7) & "u,"
sDVNs(3) = " t" & ChrW$(&H1EF7) & ","
sDVNs(4) = " ngh" & ChrW$(&HEC) & "n" & " t" & ChrW$(&H1EF7) & ","
sDVNs(5) = " tri" & ChrW$(&H1EC7) & "u" & " t" & ChrW$(&H1EF7) & ","
sDVNs(6) = " t" & ChrW$(&H1EF7) & " t" & ChrW$(&H1EF7) & ","
sDVNs(7) = " ngh" & ChrW$(&HEC) & "n" & " t" & ChrW$(&H1EF7) & " t" & ChrW$(&H1EF7) & ","
sDVNs(8) = " tri" & ChrW$(&H1EC7) & "u" & " t" & ChrW$(&H1EF7) & " t" & ChrW$(&H1EF7) & ","
sDVNs(9) = " t" & ChrW$(&H1EF7) & " t" & ChrW$(&H1EF7) & " t" & ChrW$(&H1EF7) & ","

strErr = " L" & ChrW$(&H1ED7) & "i" & " nh" & ChrW$(&H1EAD) & "p!"
strEven = " ch" & ChrW$(&H1EB5) & "n"
sHundred = " tr" & ChrW$(&H103) & "m"
sTens = " m" & ChrW$(&H1B0) & ChrW$(&H1A1) & "i"
strDong = " " & ChrW$(&H111) & ChrW$(&H1ED3) & "ng"
strDolla = " " & ChrW$(&H111) & ChrW$(&HF4) & " la"

End Select

For iScan = 1 To Len(varVal)
If IsNumeric(Mid$(varVal, iScan, 1)) Then
sVal = sVal & Mid$(varVal, iScan, 1)
ElseIf Mid$(varVal, iScan, 1) = "$" Or UCase(Mid$(varVal, iScan, 3)) = "USA" Then
strCurrency = strDolla
ElseIf LCase(Mid$(varVal, iScan, Len("ñ"))) = "ñ" Or _
LCase(Mid$(varVal, iScan, Len("d"))) = "d" Or _
LCase(Mid$(varVal, iScan, Len("vnd"))) = "vnd" Or _
LCase(Mid$(varVal, iScan, 1)) = ChrW$(&H111) Or _
LCase(Mid$(varVal, iScan, Len("®"))) = "®" Then
strCurrency = strDong
End If
Next iScan

iVal = Len(sVal)

If iVal > 0 And iVal < 15 Then
sTemp = strCurrency
For i = iVal To 1 Step -1
iChar = Val(Mid$(sVal, i, 1))
iCol = iVal - (i - 1)
Select Case (iCol Mod 3)
Case 1
If iChar = 0 And iVal > 1 Then
If iVal = iCol + 1 Then
If Mid$(sVal, i - 1, 1) <> "0" Then
sTemp = sDVNs(iCol \ 3) & sTemp
End If
ElseIf iVal > iCol + 1 Then
If Val(Mid$(sVal, i - 2, 2)) > 0 Then
sTemp = sDVNs(iCol \ 3) & sTemp
End If
Else
sTemp = sTemp
End If
Else
If iChar = 1 And iVal > iCol Then
If Val(Mid$(sVal, i - 1, 1)) > 1 Then
iChar = 11
End If
ElseIf iChar = 4 And iVal > iCol Then
If Val(Mid$(sVal, i - 1, 1)) > 1 Then
iChar = 14
End If
ElseIf iChar = 5 And iVal > iCol Then
If Val(Mid$(sVal, i - 1, 1)) > 0 Then
iChar = 15
End If
End If
sTemp = sDVs(iChar) & sDVNs(iCol \ 3) & sTemp
End If
Case 2
If iChar > 1 Then
sTemp = sDVs(iChar) & sTens & sTemp
Else
If iChar = 1 Then
iChar = 10
ElseIf iChar = 0 And (Mid$(sVal, i + 1, 1) <> "0") Then
iChar = 12
Else
iChar = 13
End If
sTemp = sDVs(iChar) & sTemp
End If
Case 0
If iChar = 0 And ((Mid$(sVal, i + 1, 1) = "0") And (Mid$(sVal, i + 2, 1) = "0")) Then
sTemp = sTemp
Else
sTemp = sDVs(iChar) & sHundred & sTemp
End If
End Select
Next i
ElseIf iVal = 0 Then
sTemp = ""
End If

sTemp = Trim(sTemp)
If Right$(sTemp, 1) = "," Then
sTemp = Mid$(sTemp, 1, Len(sTemp) - 1)
End If

NumberToText = UCase$(Left$(sTemp, 1)) & Mid$(sTemp, 2)

Pro_Next:

Exit Function

Pro_Err:

GoTo Pro_Next

End Function

Ngọc Thanh