数字小写自动转换为大写，请求上传示例

dickyzhang

数字小写自动转换为大写，请求上传示例

pengkuo

这是一个在网上找的东西，希望对你有点帮助，

阿拉伯数字转大写(用在财务金额的转换)添加过程，函数如下：


Public Function Num2Str(num As Double) As String
If num >= 1000000000 Then Exit Function
    Dim temp1 As String
    Dim temp2 As String
    Dim temp3 As String
    x = 0
    temp1 = "零壹贰叁肆伍陆柒捌玖"
    temp2 = "元拾佰仟万拾佰仟亿"
    temp3 = "角分"
    ss = Round(num, 2)
    s = Split(ss, ".")
    ss = Trim$(s(0))
For i = 1 To Len(ss)
n = Val(Mid$(ss, i, 1)) + 1

Num2Str = Num2Str & Mid$(temp1, n, 1) & Mid$(temp2, Len(ss) - i + 1, 1)

If Right(Num2Str, 2) = "零亿" Then Num2Str = Left(Num2Str, Len(Num2Str) - 2) & "亿"
If Right(Num2Str, 2) = "零万" Then Num2Str = Left(Num2Str, Len(Num2Str) - 2) & "万"
If Right(Num2Str, 2) = "零仟" Then Num2Str = Left(Num2Str, Len(Num2Str) - 2)
If Right(Num2Str, 2) = "零元" Then Num2Str = Left(Num2Str, Len(Num2Str) - 2) & "元"
If Right(Num2Str, 2) = "零佰" Then Num2Str = Left(Num2Str, Len(Num2Str) - 2)
If Right(Num2Str, 2) = "零拾" Then Num2Str = Left(Num2Str, Len(Num2Str) - 2)

Next i

For i = 1 To Len(Num2Str)
If Mid(Num2Str, i, 1) = "仟" And Mid(Num2Str, i + 2, 1) = "万" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "仟" And Mid(Num2Str, i + 2, 1) = "拾" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "仟" And Mid(Num2Str, i + 2, 1) = "元" Then
If Mid(Num2Str, i + 1, 1) = "万" Then
Else
Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
End If
End If
If Mid(Num2Str, i, 1) = "佰" And Mid(Num2Str, i + 2, 1) = "元" Then
If Mid(Num2Str, i + 1, 1) = "万" Then
Else
Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
End If
End If
If Mid(Num2Str, i, 1) = "万" And Mid(Num2Str, i + 2, 1) = "佰" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "万" And Mid(Num2Str, i + 2, 1) = "拾" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "万" And Mid(Num2Str, i + 2, 1) = "元" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "佰" And Mid(Num2Str, i + 2, 1) = "万" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "亿" And Mid(Num2Str, i + 2, 1) = "拾" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "亿" And Mid(Num2Str, i + 2, 1) = "佰" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)
If Mid(Num2Str, i, 1) = "亿" And Mid(Num2Str, i + 2, 1) = "万" Then Num2Str = Left(Num2Str, i) & "零" & Mid(Num2Str, i + 1, Len(Num2Str) - i)

Next i


If UBound(s) >= 1 Then
ss = Trim$(s(1))
For i = 1 To 2
n = Val(Mid$(ss, i, 1))
If n <> 0 Then
Num2Str = Num2Str & Mid$(temp1, n + 1, 1) & Mid$(temp3, i, 1)
Else
If Right$(Num2Str, 1) <> "零" Then Num2Str = Num2Str & "零"
End If
Next i
If Right$(Num2Str, 1) = "零" Then Num2Str = Left$(Num2Str, Len(Num2Str) - 1)
Else
Num2Str = Num2Str & "整"
End If

End Function



使用如下：


Text52.Value = Num2Str(Text43.Value)

yefei80

好的

浩雨

供参考：《另类：金额大写转换》http://www.office-cn.net/forum.php?mod=viewthread&tid=49801&replyID=&skin=1

escape_memory

还要3个贴子

escape_memory

光有代码  我也运行不起来啊

escape_memory

我也是啊

slmhd

我也想找

yangzn

几年前写,不过代码有点乱,另外就是最大,9仟多万..
Option Explicit

Public Function dx(x As Currency) As String
'大写转换函数
Dim str As String
Dim temp As String
Dim iDotPosition As Integer
Dim tempDec As String
    str = CStr(x)
    iDotPosition = InStr(str, ".")
Select Case iDotPosition
    Case 0
        '没有小数
        dx = dxNoDec(str)
        If Right(dx, 1) = "元" Then
            dx = dx & "正"
        Else
            dx = dx & "元正"
        End If
    Case 1
        '个位及个位以上为0
        dx = dxNoInt(str)
    Case Else
        '正常情况
        temp = Left(str, iDotPosition - 1)
        dx = dxNoDec(temp)
        temp = Mid(str, iDotPosition)
        tempDec = dxNoInt(temp)
        If Right(dx, 1) <> "元" Then
            dx = dx & "元"
        End If
        If Mid(tempDec, 2, 1) = "分" Then
            tempDec = "零" & tempDec
        End If
        dx = dx & tempDec
        
        
    End Select
   
    Debug.Print dx
    dx = decw(dx)

End Function
Function decw(x As String) As String
'删除多余的万字
    Dim temp As String
    Dim countW As Integer
    Dim i As Integer
    temp = x
    For i = 1 To Len(x)
        If Mid(x, i, 1) = "万" Then
            countW = countW + 1
        End If
    Next
    If countW > 1 Then
        decw = myReplace(temp, "万", "", countW - 1)
    End If
    If countW <= 1 Then
        decw = temp
    End If
End Function
Function dxNoDec(x As String) As String
    '没有小数的读法
    Dim str As String
    Dim temp As String
    Dim iLen As Integer
    Dim i As Integer
    Dim perStr As String '低一位的数字
    perStr = "0"
    iLen = Len(x)
    For i = 0 To iLen - 1  '从低位读起,然后到高位
        temp = Mid(x, iLen - i, 1)
        If temp = "0" Then  '如果当前读出的是零
            If perStr = "0" Then
                '并且前一个低位,也为零,就跳到下一个读位
            Else
                dxNoDec = x2d(temp) & dxNoDec
            End If
        Else
            dxNoDec = x2d(temp) & w2n(i + 1) & dxNoDec
        End If
        perStr = temp
    Next i
End Function
Function dxNoInt(x As String) As String
    '小数点前没有数字
    Dim temp As String
    temp = Mid(x, 3, 1)
    If temp = "0" Or temp = "" Then
        temp = Mid(x, 2, 1)
        dxNoInt = x2d(temp) & "角正"
    Else
        temp = Mid(x, 2, 1)
        If temp = "0" Then
            temp = Mid(x, 3, 1)
            dxNoInt = x2d(temp) & "分"
        Else
            dxNoInt = x2d(temp) & "角"
            temp = Mid(x, 3, 1)
            dxNoInt = dxNoInt & x2d(temp) & "分"
        End If
    End If
End Function
Function x2d(x As String) As String
'阿拉伯数字转换为大写
    Select Case x
    Case "0"
        x2d = "零"
    Case "1"
        x2d = "壹"
    Case "2"
        x2d = "贰"
    Case "3"
        x2d = "叁"
    Case "4"
        x2d = "肆"
    Case "5"
        x2d = "伍"
    Case "6"
        x2d = "陆"
    Case "7"
        x2d = "柒"
    Case "8"
        x2d = "捌"
    Case "9"
        x2d = "玖"
    Case Else
        MsgBox "错误在  x2d 函数"
    End Select
End Function
Function w2n(x As Integer) As String
'位数以数字记法 转换为个十百千
'最大千万
    Select Case x
    Case 1
        w2n = "元"
    Case 2
        w2n = "拾"
    Case 3
        w2n = "佰"
    Case 4
        w2n = "仟"
    Case 5
        w2n = "万"
    Case 6
        w2n = "拾万"
    Case 7
        w2n = "佰万"
    Case 8
        w2n = "仟万"
    Case Else
        MsgBox "数字太大或不正确 在 w2n 函数"
        w2n = ""
    End Select
End Function
Function myReplace(x As String, sFind As String, sReplace As String, coun

ddssaa

我也遇到金额转换大写的问题