Một cách Đọc số tiền bằng chữ

[kiennahang]

- Nguồn: http://tuygialai.blogspot.com/2014/08/oc-so-ra-chu-trong-excel.html

- Cách sử dụng: =SoTien(Number; Optional)

VD: tại ô A1 có nội dung: 123.206
Tại ô A2 nhập:
=SoTien(A1) --->Kết quả: Một trăm hai mươi ba ngàn hai trăm lẻ sáu
=SoTien(A1;1) --->Một trăm hai mươi ba ngàn hai trăm lẻ sáu đồng
=SoTien(A1;2) --->Một trăm hai mươi ba ngàn hai trăm lẻ sáu đồng chẵn
=SoTien(A1;3) --->Một trăm hai mươi ba ngàn hai trăm lẻ sáu VND
=SoTien(A1;4) --->Một trăm hai mươi ba ngàn hai trăm lẻ sáu USD
'=SoTien(A1;5) --->Một trăm hai mươi ba ngàn hai trăm lẻ sáu GBP

'-------------CODE--------------------------------------------------------------

'Attribute VB_Name = "Module1"
Private Function Doc(so As String) As String
Dim j As Integer, i As Integer
Dim s1 As String, s2 As String
    s1 = "10" + so
    j = Len(so)
    s2 = ""
    For i = 3 To j + 2
        Select Case Mid(s1, i, 1)
            Case "0":
                Select Case (j - i + 2) Mod 3
                    Case 0: If j = 1 Then s2 = " kh" + ChrW(244) + "ng"
                    Case 1:
                        If Mid(s1, i + 1, 1) <> "0" Then s2 = s2 + " l" + ChrW(7867)
                    Case 2:
                        If Mid(s1, i + 1, 2) <> "00" Then s2 = s2 + " kh" + ChrW(244) + "ng"
                End Select
            Case "1":
                Select Case (j - i + 2) Mod 3
                    Case 0:
                        c = Mid(s1, i - 1, 1)
                        If c <> "0" And c <> "1" Then
                            s2 = s2 + " m" + ChrW(7889) + "t"
                        Else: s2 = s2 + " m" + ChrW(7897) + "t"
                        End If
                    Case 1: s2 = s2 + " m" + ChrW(432) + ChrW(7901) + "i"
                    Case 2: s2 = s2 + " m" + ChrW(7897) + "t"
                End Select
            Case "2": s2 = s2 + " hai"
            Case "3": s2 = s2 + " ba"
            Case "4": s2 = s2 + " b" + ChrW(7889) + "n"
            Case "5":
                If ((j - i + 2) Mod 3 = 0 And Mid(s1, i - 1, 1) <> "0") Then
                    s2 = s2 + " l" + ChrW(259) + "m"
                Else: s2 = s2 + " n" + ChrW(259) + "m"
                End If
            Case "6": s2 = s2 + " s" + ChrW(225) + "u"
            Case "7": s2 = s2 + " b" + ChrW(7843) + "y"
            Case "8": s2 = s2 + " t" + ChrW(225) + "m"
            Case "9": s2 = s2 + " ch" + ChrW(237) + "n"
        End Select
        Select Case (j - i + 2)
            Case 1, 4, 7, 10, 13:
                c = Mid(s1, i, 1)
                If c <> "1" And c <> "0" Then s2 = s2 + " m" + ChrW(432) + ChrW(417) + "i"
            Case 2, 5, 8, 11, 14:
                If Mid(s1, i, 1) <> "0" Or Mid(s1, i + 1, 2) <> "00" Then s2 = s2 + " tr" + ChrW(259) + "m"
            Case 3, 12: If Mid(s1, i - 2, 3) <> "000" Then s2 = s2 + " ng" + ChrW(224) + "n"
            Case 6: If Mid(s1, i - 2, 2) <> "00" Then s2 = s2 + " tri" + ChrW(7879) + "u"
            Case 9: s2 = s2 + " t" + ChrW(7881)
        End Select
    Next
    Doc = Trim(s2)
    'Doc = UCase(Mid(s2, 1, 1)) + Mid(s2, 2, Len(s2) - 1)
End Function
'-----------------------------------------------------------------------------
Private Function DocRoi(so As String) As String
Dim i As Integer
Dim c As String * 1
Dim s As String
    s = ""
    For i = 1 To Len(so)
        c = Mid(so, i, 1)
        Select Case c
            Case "0": s = s + "kh" + ChrW(244) + "ng "
            Case "1": s = s + "m" + ChrW(7897) + "t "
            Case "2": s = s + "hai "
            Case "3": s = s + "ba "
            Case "4": s = s + "b" + ChrW(7889) + "n "
            Case "5": s = s + "n" + ChrW(259) + "m "
            Case "6": s = s + "s" + ChrW(225) + "u "
            Case "7": s = s + "b" + ChrW(7843) + "y "
            Case "8": s = s + "t" + ChrW(225) + "m "
            Case "9": s = s + "ch" + ChrW(237) + "n "
            Case ".", ",": s = s + "ph" + ChrW(7849) + "y "
        End Select
        DocRoi = Trim(s)
    Next
End Function
'-----------------------------------------------------------------------------
Public Function SoTien(so As String, Optional donvi As String = 0) As String
    Select Case donvi
        Case 0: donvi = ""
        Case 1: donvi = " " + ChrW(273) + ChrW(7891) + "ng"
        Case 2: donvi = " " + ChrW(273) + ChrW(7891) + "ng ch" + ChrW(7861) + "n"
        Case 3: donvi = " VND"
        Case 4: donvi = " USD"
        Case 5: donvi = " GBP"
    End Select
    so = Trim(Str(Round(Val(so), 0)))
    SoTien = Doc(so) + " " + Trim(donvi)
    SoTien = UCase(Mid(SoTien, 1, 1)) + Mid(SoTien, 2, Len(SoTien) - 1)
End Function
'-----------------------------------------------------------------------------
Private Function XuLy(so As String) As String
Dim j As Byte, i As Byte
Dim c As String * 1
Dim d As Boolean
Dim s1 As String
    d = False
    For j = 1 To Len(so)
        If Mid(so, j, 1) < "0" Or Mid(so, j, 1) > "9" Then
            d = True
            c = Mid(so, j, 1)
            i = j
        End If
    Next
    s1 = ""
    For j = 1 To Len(so)
        If Mid(so, j, 1) >= "0" And Mid(so, j, 1) <= "9" Then s1 = s1 + Mid(so, j, 1)
        If j = i Then s1 = s1 + ","
    Next
    XuLy = s1
End Function
'-----------------------------------------------------------------------------
Public Function DocSo(so As String, Optional k As Byte = 0) As String
Dim s1 As String, s2 As String
Dim i As Integer
    'so = Trim(Str(Val(so)))
    so = XuLy(so)
    i = 1
    Do
        s1 = s1 + Mid(so, i, 1)
        i = i + 1
    Loop Until i = Len(so) + 1 Or Mid(so, i, 1) < "0" Or Mid(so, i, 1) > "9"
    For j = i + 1 To Len(so)
            If Mid(so, j, 1) >= "0" And Mid(so, j, 1) <= "9" Then s2 = s2 + Mid(so, j, 1)
    Next j
    If s1 = "" Then Exit Function
    If k = 0 Then
        DocSo = Doc(s1)
    Else: DocSo = DocRoi(s1)
    End If
    If s2 <> "" Then
        If k = 0 Then
            DocSo = DocSo + " ph" + ChrW(7849) + "y " + Doc(s2)
        Else: DocSo = DocSo + " ph" + ChrW(7849) + "y " + DocRoi(s2)
        End If
        'For i = 1 To Len(s2)
        '    DocSo = DocSo + " " + Doc(Mid(s2, i, 1))
        'Next i
    End If
    If Len(DocSo) > 1 Then
        DocSo = UCase(Mid(DocSo, 1, 1)) + Mid(DocSo, 2, Len(DocSo) - 1)
    End If
End Function

'--------------------------END ---------------------------------------------------