人民币、数字大小写转换

'人民币数字转大写
Public Function RMBChangeCaps(ByVal n As Variant) As String
    Dim s1, s2, s3
    Dim sBal As Variant
    Dim s As String
   
    s1 = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
    s2 = Array("整", "", "拾", "佰", "仟")
    s3 = Array("元", "万", "亿", "万", "亿")    '间隔都是4位
   
    sBal = Split(CStr(CDbl(n)), ".")
   
    '对角分进行处理，如果没有角分，s="整"
    If UBound(sBal) Then
        If Left(sBal(1), 1) <> "0" Then s = s1(CInt(Left(sBal(1), 1))) & "角"
        If Len(sBal(1)) = 2 And Right(sBal(1), 1) <> "0" Then s = s & s1(CInt(Right(sBal(1), 1))) & "分"
    Else
        s = s2(0)   '整
    End If
   
    Dim l As Integer, c As String
    Dim i As Integer, j As Integer
    If Len(sBal(0)) > 0 Then
        sBal(0) = StrReverse(sBal(0))
        l = Len(sBal(0))
        For i = 0 To 4
            If i * 4 > l Then Exit For
            For j = 1 To 4
                If i * 4 + j > l Then Exit For
                If j = 1 Then s = s3(i) & s
                c = Mid(sBal(0), i * 4 + j, 1)
                s = IIf(c = "0", s1(0), s1(CInt(c)) & s2(j)) & s
            Next j
        Next i
    End If
    For i = 0 To 2: s = Replace(s, s1(0) & s1(0), s1(0)): Next i    '最多3次去掉所有"零零"
    For i = 0 To 2: s = Replace(s, s1(0) & s3(i), s3(i)): Next i    '最多3次去掉所有"万万"
    RMBChangeCaps = s
End Function

 

 

Public Function 人民币大写转小写(ByVal s As String) As Double
'最大转换9999 9999 9999 9999.99
    Const s1 As String = "拾佰仟万亿元角分壹贰叁肆伍陆柒捌玖一二三四五六七八九"
    Dim c(17) As Byte   '金额,15-0位放元的值，16位放角的值，17位放分的值
    Dim ii As Integer, k As Integer
    Dim p As Integer, iPos As Integer
   
    For ii = 0 To UBound(c)
        c(ii) = &H30    '将所有位放"0"
    Next ii
   
    p = 4: iPos = 15
    For ii = Len(s) To 1 Step -1
        k = InStr(1, s1, Mid(s, ii, 1))
        If k Then
            Select Case k
                Case 1 To 3: iPos = p * 4 - k - 1 '拾佰仟
                Case 4 To 5: p = IIf(k = 4, p - 1, 2): iPos = p * 4 - 1  '万亿
                Case 6 To 8: iPos = 9 + k '元角分
                Case 9 To 26: c(iPos) = IIf(k < 18, 40, 31) + k '壹贰叁肆伍陆柒捌玖一二三四五六七八九
            End Select
        End If
    Next ii
   
    人民币大写转小写 = CDbl(StrConv(c, vbUnicode)) / 100
End Function

 

 

Public Function 大写数字转小写(s As String) As Double
    Const s1 As String = "〇一二三四五六七八九拾佰仟万亿"
    Dim ii As Integer
    Dim c As Variant
    c = Array("0", "〇", "十", "拾", "百", "佰", "千", "仟")
    For ii = 0 To UBound(c) - 1 Step 2
        s = Replace(s, c(ii), c(ii + 1))
    Next ii
   
    Dim cFlag As Boolean
    cFlag = False
    For ii = 11 To 15
        If InStr(1, s, Mid(s1, ii, 1)) Then
            cFlag = True
            Exit For
        End If
    Next ii
   
    If cFlag Then
        大写数字转小写 = 人民币大写转小写(s)
    Else
        For ii = 1 To 10
            s = Replace(s, Mid(s1, ii, 1), ii - 1)
        Next ii
        大写数字转小写 = CDbl(s)
    End If
End Function

 

 

Public Function 小写数字转大写(n As Long) As String
    Const s1 As String = "〇一二三四五六七八九"
    Dim c As String, ii As Integer
   
    c = CStr(n)
    For ii = 1 To Len(s1)
        c = Replace(c, ii - 1, Mid(s1, ii, 1))
    Next ii
   
    小写数字转大写 = c
End Function

 

'用法例子

Sub a()
    Debug.Print 人民币大写转小写(20091213)
End Sub