Tạo code VBA đổi số thành chữ trong Excel

Tên hàm chưa hợp lệ nên chưa tạo mã. Sửa tên ở mục “Đổi tên hàm” hoặc dùng tên mặc định.

' ============================================================
' Generated by sothanhchu.com - Vietnamese number to words (VBA)
' Function: DOCSO(value) - whole numbers only
' Mode: number (whole numbers only)
' Words: nghin / linh / mot / bon / lam / ty
' Case: sentence
' No network access, no file access, no shell commands, no add-ins.
' Plain ASCII source: Vietnamese letters are built with ChrW().
' Input: a number below 1E+15, or text made only of digits.
' Anything else (decimals, 1E+15 or more, non-numeric text) returns #VALUE!.
' ============================================================
Option Explicit
Private Const STC_IS_MONEY As Boolean = False
Private Const STC_OMIT_ZERO_HUNDRED As Boolean = False
Private Const STC_CAPITALIZE As Boolean = True
Private Const STC_MAX_DIGITS As Long = 36
Private Const STC_ERR_VALUE As Long = 2015 ' #VALUE!

Private stcReady As Boolean
Private stcDigit(0 To 9) As String
Private stcHundred As String, stcTen As String, stcTens As String
Private stcThousand As String, stcMillion As String, stcBillion As String
Private stcZeroTens As String, stcOne As String, stcFour As String, stcFive As String
Private stcNeg As String, stcUnit As String, stcWhole As String

Public Function DOCSO(ByVal stcValue As Variant) As Variant
    DOCSO = stcConvert(stcValue)
End Function

Private Sub stcInit()
    If stcReady Then Exit Sub
    stcDigit(0) = "kh" & ChrW(244) & "ng"   ' khong
    stcDigit(1) = "m" & ChrW(7897) & "t"   ' mot
    stcDigit(2) = "hai"   ' hai
    stcDigit(3) = "ba"   ' ba
    stcDigit(4) = "b" & ChrW(7889) & "n"   ' bon
    stcDigit(5) = "n" & ChrW(259) & "m"   ' nam
    stcDigit(6) = "s" & ChrW(225) & "u"   ' sau
    stcDigit(7) = "b" & ChrW(7843) & "y"   ' bay
    stcDigit(8) = "t" & ChrW(225) & "m"   ' tam
    stcDigit(9) = "ch" & ChrW(237) & "n"   ' chin
    stcHundred = "tr" & ChrW(259) & "m"   ' tram
    stcTen = "m" & ChrW(432) & ChrW(7901) & "i"   ' muoi
    stcTens = "m" & ChrW(432) & ChrW(417) & "i"   ' muoi
    stcThousand = "ngh" & ChrW(236) & "n"   ' nghin
    stcMillion = "tri" & ChrW(7879) & "u"   ' trieu
    stcBillion = "t" & ChrW(7927)   ' ty
    stcZeroTens = "linh"   ' linh
    stcOne = "m" & ChrW(7889) & "t"   ' mot
    stcFour = "b" & ChrW(7889) & "n"   ' bon
    stcFive = "l" & ChrW(259) & "m"   ' lam
    stcNeg = ChrW(226) & "m"   ' am
    stcUnit = ""
    stcWhole = ""
    stcReady = True
End Sub

Private Function stcConvert(ByVal v As Variant) As Variant
    Dim neg As Boolean, digits As String, s As String, cellRef As Object
    If IsObject(v) Then ' a cell reference can arrive as a Range object
        Set cellRef = v
        v = cellRef.Value
    End If
    If IsError(v) Then stcConvert = v: Exit Function
    If IsArray(v) Then stcConvert = CVErr(STC_ERR_VALUE): Exit Function
    If IsEmpty(v) Or IsNull(v) Then stcConvert = "": Exit Function
    If VarType(v) = vbString Then
        If Len(Trim$(v)) = 0 Then stcConvert = "": Exit Function
    End If
    If Not stcParse(v, neg, digits) Then stcConvert = CVErr(STC_ERR_VALUE): Exit Function
    stcInit
    s = stcIntegerWords(digits)
    If neg Then s = stcNeg & " " & s
    If STC_IS_MONEY Then
        s = s & " " & stcUnit
        If Len(stcWhole) > 0 Then s = s & " " & stcWhole
    End If
    If STC_CAPITALIZE Then s = stcCapFirst(s)
    stcConvert = s
End Function

' Accepts a whole number: a numeric cell below 1E+15, or text made only of digits (optional leading minus).
Private Function stcParse(ByVal v As Variant, ByRef neg As Boolean, ByRef digits As String) As Boolean
    Dim s As String, i As Long, c As Long
    neg = False
    digits = ""
    Select Case VarType(v)
        Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
            If Abs(v) >= 1E+15 Then Exit Function
            If v <> Fix(v) Then Exit Function
            neg = (v < 0)
            digits = Format$(Abs(v), "0")
        Case vbString
            s = Trim$(v)
            If Len(s) > 255 Then Exit Function
            If Left$(s, 1) = "-" Then
                neg = True
                s = Mid$(s, 2)
            End If
            If Len(s) = 0 Then Exit Function
            For i = 1 To Len(s)
                c = AscW(Mid$(s, i, 1))
                If c < 48 Or c > 57 Then Exit Function
            Next i
            digits = s
        Case Else
            Exit Function
    End Select
    digits = stcTrimZeros(digits)
    If Len(digits) > STC_MAX_DIGITS Then Exit Function
    If Len(digits) = 0 Then neg = False
    stcParse = True
End Function

Private Function stcTrimZeros(ByVal s As String) As String
    Dim i As Long
    i = 1
    Do While i <= Len(s)
        If Mid$(s, i, 1) <> "0" Then Exit Do
        i = i + 1
    Loop
    stcTrimZeros = Mid$(s, i)
End Function

Private Sub stcAdd(ByRef s As String, ByVal w As String)
    If Len(w) = 0 Then Exit Sub
    If Len(s) > 0 Then s = s & " "
    s = s & w
End Sub

' Whole number (digits only) -> words. Groups of three digits; from 10^9 on the number is read in
' nine-digit chunks, each followed by the billion word once per chunk level (nghin ty, trieu ty, ty ty ...).
Private Function stcIntegerWords(ByVal digits As String) As String
    Dim cnt As Long, i As Long, g As Long, chunk As Long, pos As Long, lowerG As Long, k As Long, topIdx As Long
    Dim lowest As Boolean, piece As String, outText As String
    Dim vals() As Long
    If Len(digits) = 0 Then stcIntegerWords = stcDigit(0): Exit Function
    cnt = (Len(digits) + 2) \ 3
    digits = String$(cnt * 3 - Len(digits), "0") & digits
    ReDim vals(0 To cnt - 1)
    topIdx = -1
    For i = 0 To cnt - 1
        vals(i) = CLng(Mid$(digits, i * 3 + 1, 3))
        If topIdx < 0 And vals(i) > 0 Then topIdx = i
    Next i
    For i = 0 To cnt - 1
        If vals(i) > 0 Then
            g = cnt - 1 - i
            pos = g Mod 3
            chunk = g \ 3
            piece = stcGroupWords(vals(i), (i = topIdx))
            If pos = 1 Then stcAdd piece, stcThousand
            If pos = 2 Then stcAdd piece, stcMillion
            If chunk > 0 Then
                lowest = True
                For lowerG = chunk * 3 To g - 1
                    If vals(cnt - 1 - lowerG) > 0 Then lowest = False
                Next lowerG
                If lowest Then
                    For k = 1 To chunk
                        stcAdd piece, stcBillion
                    Next k
                End If
            End If
            stcAdd outText, piece
        End If
    Next i
    stcIntegerWords = outText
End Function

' One group of three digits (1..999). isTop = the most significant non-zero group (no leading "khong tram").
Private Function stcGroupWords(ByVal v As Long, ByVal isTop As Boolean) As String
    Dim h As Long, t As Long, u As Long, zeroTensCtx As Boolean, s As String
    h = v \ 100
    t = (v \ 10) Mod 10
    u = v Mod 10
    If h > 0 Then
        stcAdd s, stcDigit(h)
        stcAdd s, stcHundred
    ElseIf (Not isTop) And (Not STC_OMIT_ZERO_HUNDRED) Then
        stcAdd s, stcDigit(0)
        stcAdd s, stcHundred
    End If
    zeroTensCtx = (t = 0) And (u > 0) And ((h > 0) Or (Not isTop))
    If t = 0 Then
        If zeroTensCtx Then stcAdd s, stcZeroTens
    ElseIf t = 1 Then
        stcAdd s, stcTen
    Else
        stcAdd s, stcDigit(t)
        stcAdd s, stcTens
    End If
    If u > 0 Then
        If u = 1 And t >= 2 Then
            stcAdd s, stcOne
        ElseIf u = 4 And (t >= 2 Or zeroTensCtx) Then
            stcAdd s, stcFour
        ElseIf u = 5 And t >= 1 Then
            stcAdd s, stcFive
        Else
            stcAdd s, stcDigit(u)
        End If
    End If
    stcGroupWords = s
End Function

' Upper-case the first letter only. Every Vietnamese reading starts with an ASCII letter or the letter a-circumflex.
Private Function stcCapFirst(ByVal s As String) As String
    Dim c As Long
    If Len(s) = 0 Then Exit Function
    c = AscW(Left$(s, 1))
    If c = 226 Then
        stcCapFirst = ChrW(194) & Mid$(s, 2)
    ElseIf c < 128 Then
        stcCapFirst = UCase$(Left$(s, 1)) & Mid$(s, 2)
    Else
        stcCapFirst = s
    End If
End Function

Chưa chạy thử trong Microsoft Excel thật. Mã đã được chạy bằng LibreOffice (chế độ tương thích VBA). Sau khi dán, đối chiếu bảng “Kiểm tra sau khi cài” bên dưới. Ô số chỉ nhận số nguyên dưới 1E+15; số dài nhập dưới dạng văn bản.

Mã chạy hoàn toàn trong Excel của bạn, không cần mạng. Đọc qua trước khi dán: cách tự kiểm tra.