人民币小写转大写7套VBA代码汇总，最精代码仅1行

vitrel

       人民币小写转大写，表面上看似简单，但因其规则较多，因此想要完美实现，有些难度。本人从网上收集了7套VBA代码，都是用自定义函数的形式实现人民币小写转大写的，已经汇总到1个工作簿中供各位参考比对，最令人叹为观止的是其中的第7套代码仅用了1行即可实现人民币小写转大写，实在值得大家学习。

ivccav

实在值得大家学习，只是楼主不厚道，就几句代码，还让别人下载你的附件。

vitrel

ivccav 发表于 2017-12-8 22:30
实在值得大家学习，只是楼主不厚道，就几句代码，还让别人下载你的附件。

抱歉抱歉，我是新手，不知道这里的规矩。我从网上收集了这么几套转换方案，但每套方案都有不足之处，有的不支持负数，有的不支持0元，有的不能处理3位小数……因此我特意对它们放在一起，通过比较，让各位在使用过程中能根据实际使用情况选用最适合的方案，因此才想到把汇总整理好的文件上传的，下载附件应该不用扣分或扣经验值吧？这个我真不知，打扰到大家，实在抱歉！

hzruziniu

vitrel 发表于 2017-12-9 19:38
抱歉抱歉，我是新手，不知道这里的规矩。我从网上收集了这么几套转换方案，但每套方案都有不足之处，有的 ...

最短一段代码换这句更完美:

Function dx(M)
    dx = Replace(Replace(Replace(Join(Application.Text(Split(Format(M, " 0. 0 0;负 0. 0 0;   ")), ["[DBnum2]"&{0,"","元0角;;元零","0分;;整"}]), a), "零元零", a), "零元", a), "零整", "整")
End Function

一、你的代码大写的负数前面为“-”号，这段代码为“负”字
二、你的代码如：25.25元，显示为：贰拾伍元零贰角伍分，这段代码显示为：贰拾伍元贰角伍分，
     你的代码多出一个不必要的“零”。

km122712

hzruziniu 发表于 2017-12-9 20:58
最短一段代码换这句更完美:

Function dx(M)

感谢分享！你的代码结果更符合标准。

niko88819

vitrel 发表于 2017-12-9 19:38
抱歉抱歉，我是新手，不知道这里的规矩。我从网上收集了这么几套转换方案，但每套方案都有不足之处，有的 ...

由于打不开xlsm代码，楼主能贴出现错误吧代码吗？小师妹在此非常感谢你，因为花今天送完了，明天补送啰

vitrel

hzruziniu 发表于 2017-12-9 20:58
最短一段代码换这句更完美:

Function dx(M)

感谢感谢，受教了！！

lcjy11185

大写人民币自定义函数

三流高手

谢谢楼主，学习了。

vitrel

niko88819 发表于 2017-12-9 23:24
由于打不开xlsm代码，楼主能贴出现错误吧代码吗？小师妹在此非常感谢你，因为花今天送完了，明天补送啰

Function rmba(M)
    y = Int(Round(100 * Abs(M)) / 100)
    j = Round(100 * Abs(M) + 0.00001) - y * 100
    f = Round((j / 10 - Int(j / 10)) * 10)
    a = IIf(y < 1, "", Application.Text(y, "[DBNum2]") & "元")
    b = IIf(j > 9.4, Application.Text(Int(j / 10), "[DBNum2]") & "角", IIf(y < 1, "", IIf(f > 0.4, "零", "")))
    c = IIf(f < 1, "整", Application.Text(Round(f, 0), "[DBNum2]") & "分")
    rmba = IIf(Abs(M) < 0.005, "", IIf(M < 0, "负" & a & b & c, a & b & c))
End Function

'http://club.excelhome.net/thread-143657-1-1.html
Function rmbb(M)
    y = Int(Round(100 * Abs(M)) / 100)
    j = Round(100 * Abs(M)) - y * 100
    f = (j / 10 - Int(j / 10)) * 10
    a = Application.Text(y, "[DBNum2]")
    d = "元"
    If j < 10 Then e = "" Else e = "角"
    If f < 1 Then g = "整" Else g = "分"
    If f < 1 Then c = "" Else c = Application.Text(Round(f, 0), "[DBNum2]")
    If j = 0 Then b = "" Else b = Application.Text(Int(j / 10), "[DBNum2]")
    If M < 0 Then z = "负" Else z = ""
    rmbb = z & a & d & b & e & c & g
End Function

Function rmbc(M)
    y = Int(Abs(M))
    j = Round(Abs(M) - y, 2)
    f = (j * 10 - Int(j * 10)) / 10
    a = Application.Text(y, "[DBNum2]")
    d = "元"
    If j < 0.1 Then e = "" Else e = "角"
    If f < 0.01 Then g = "整" Else g = "分"
    If f < 0.01 Then c = "" Else c = Application.Text(Round(f * 100, 0), "[DBNum2]")
    If j = 0 Then b = "" Else b = Application.Text(Int(j * 10), "[DBNum2]")
    If M < 0 Then z = "负" Else z = ""
    If Int(Abs(M)) < 1 Then
        If Abs(M * 10) - Abs(Int(M) * 10) < 1 Then
            rmbc = z & c & g
        Else
            rmbc = z & b & e & c & g
        End If
    Else
        rmbc = z & a & d & b & e & c & g
    End If
End Function

'只有10行，代码精简，虽不支持负数，金额也有限制，但所用语句高明，适用的方向很广
'原创 渴死的鱼 hanlin2020@hotmail.com
'改编 inRm inrm@263.net
Function rmbd(n) 'n as single
    Const cNum = "零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
    Const cCha = "零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
    rmbd = ""
    sNum = Trim(Str(Round(n, 2) * 100)) '在这里用Round()四舍五入
    For i = 1 To Len(sNum) '逐位转换
        rmbd = rmbd + Mid(cNum, (Mid(sNum, i, 1)) + 1, 1) + Mid(cNum, 26 - Len(sNum) + i, 1)
    Next
    For i = 0 To 11 '去掉多余的零
        rmbd = Replace(rmbd, Mid(cCha, i * 2 + 1, 2), Mid(cCha, i + 26, 1))
    Next
End Function

Function rmbe(x As Double) As String
    Dim a(9) As String, b(6) As String, i As Integer, j As Integer, z As Integer, s As String, t As String, k As Long
    a(0) = "零"
    a(1) = "壹"
    a(2) = "贰"
    a(3) = "叁"
    a(4) = "肆"
    a(5) = "伍"
    a(6) = "陆"
    a(7) = "柒"
    a(8) = "捌"
    a(9) = "玖"
    b(1) = "拾"
    b(2) = "佰"
    b(3) = "仟"
    b(4) = "万"
    b(5) = "亿"
    b(6) = "万亿"
    s = CStr(x)
    i = InStr(1, s, "E")
    If i > 0 Then
        k = Mid(s, i + 1, Len(s) - i)
        s = Mid(s, 1, i - 1)
        j = InStr(1, s, ".")
        s = Replace(s, ".", "")
        If k < i - j - 1 Then
            s = Mid(s, 1, j + k - 1) & "." & Right(s, Len(s) - j - k + 1)
        Else
            s = s & String(k - i + j + 1, "0")
        End If
    End If
    i = InStr(1, s, ".")
    If i > 0 Then
        If i + 2 > Len(s) Then
            If Mid(s, i + 1, 1) > 0 Then t = "元" & a(Mid(s, i + 1, 1)) & "角整"
        Else
            If Mid(s, i + 1, 1) > 0 And Mid(s, i + 2, 1) > 0 Then
                t = "元" & a(Mid(s, i + 1, 1)) & "角" & a(Mid(s, i + 2, 1)) & "分"
            ElseIf Mid(s, i + 1, 1) > 0 And Mid(s, i + 2, 1) = 0 Then
                t = "元" & a(Mid(s, i + 1, 1)) & "角整"
            ElseIf Mid(s, i + 1, 1) = 0 And Mid(s, i + 2, 1) > 0 Then
                t = "元零" & a(Mid(s, i + 2, 1)) & "分"
            Else
                t = "元整"
            End If
        End If
        s = Left(s, i - 1)
    Else
        t = "元整"
    End If
    k = Len(s)
    If Mid(s, k, 1) = 0 Then
        i = 2
        Do Until Mid(s, k - i + 1, 1) > 0
            i = i + 1
        Loop
        t = a(Mid(s, k - i + 1, 1)) & b((i - 1) Mod 4) & b(IIf((i - 1) \ 4 = 0, 0, (i - 1) \ 4 + 3)) & t
        i = i + 1
    Else
        i = 1
    End If
    Do Until i > k
        If Mid(s, k - i + 1, 1) = 0 Then
            t = "零" & t
            j = i + 1
            Do Until j > k
                If Mid(s, k - j + 1, 1) > 0 Then
                    If IIf((j - 1) \ 4 = 0, 0, (j - 1) \ 4 + 3) = z Then
                        t = a(Mid(s, k - j + 1, 1)) & b((j - 1) Mod 4) & t
                    Else
                        t = a(Mid(s, k - j + 1, 1)) & b((j - 1) Mod 4) & b(IIf((j - 1) \ 4 = 0, 0, (j - 1) \ 4 + 3)) & t
                        z = IIf((j - 1) \ 4 = 0, 0, (j - 1) \ 4 + 3)
                    End If
                    i = j + 1
                    Exit Do
                End If
                j = j + 1
            Loop
        Else
            If IIf((i - 1) \ 4 = 0, 0, (i - 1) \ 4 + 3) = z Then
                t = a(Mid(s, k - i + 1, 1)) & b((i - 1) Mod 4) & t
            Else
                t = a(Mid(s, k - i + 1, 1)) & b((i - 1) Mod 4) & b(IIf((i - 1) \ 4 = 0, 0, (i - 1) \ 4 + 3)) & t
                z = IIf((i - 1) \ 4 = 0, 0, (i - 1) \ 4 + 3)
            End If
            i = i + 1
        End If
    Loop
    If Len(t) - Len(Replace(t, "亿", "")) > 1 Then t = Replace(t, "万亿", "万")
    rmbe = t
End Function

Function rmbf(M)
    rmbf = Replace(Replace(Replace(Join(Application.Text(Split(Format(M, " 0. 0 0;;   ")), ["[DBnum2]"&{0,"","元0角;;元","0分;;整"}]), a), "零元", a), "元", "元零"), "零整", "整")
End Function