[原创]中文小写转阿拉伯数字自定义函数

时光鸟

aman1516 发表于 2013-6-17 19:27
Good!  是数字中的“○”，可能输入法版本不同，或半角全角的问题。不管怎样，用替换或复制方法，只要数据中 ...

你8楼中回复的就是word、excel中的特殊字符圈圈，不是阿拉伯数字0！不管是word、excel中特殊字符圈圈，还是阿拉伯数字0，在中文小写中的表达都非常不规范，达不到转换的效果，通常在中文小写中表示0的只有”〇“ 和”零“两种常用表达方式，甚至 ”零“这种表达都不算规范（因为是中文大写），由于 ”零“使用得比较多也就支持了，其它在中文小写中表示0的非正规符号都不支持，也没有后续支持的打算！

wzsy2_mrf

楼主的程序我实在看不懂。测试的时候也出现一些问题，如："万五百十万"，这种数会出现错误。
我自己写了一个，用递归的，测试没有发现问题：
Private Function toNum1(mystr As String) As Long
'mrf 于2014年4月26日
Dim i As Integer, myPos1 As Integer, myPos2%, falg%    'falg标志最高位在字串中出现位置，myPos2-11 表示最高位次数
Dim str1 As String
Dim comString As String
comString = "一二三四五六七八九〇零十百千万┩兆╊亿0123456789" '加入┩╊为处理方便，如在有可能出现的场合可先清除

If mystr = "" Then
    toNum1 = 0
    Exit Function
End If
myPos2 = 0
falg = 0
For i = 1 To Len(mystr)
    str1 = Mid(mystr, i, 1)
    myPos1 = InStr(1, comString, str1, vbTextCompare)
    Select Case myPos1
        Case 1 To 9
            mystr = Left$(mystr, i - 1) & Trim(Str(myPos1)) & Right$(mystr, Len(mystr) - i) 'trim 去空串
        Case 10, 11
            mystr = Left$(mystr, i - 1) & "0" & Right$(mystr, Len(mystr) - i)
        Case 12 To 19
            If myPos1 >= myPos2 Then
                falg = i
                myPos2 = myPos1
            End If
        Case 20 To 30
        Case Else
            Exit Function
    End Select
Next

Select Case falg
    Case 0 '代表字串为纯数字
        Dim mynum As Long
        For i = Len(mystr) To 1 Step -1
            mynum = mynum + Val(Mid(mystr, i, 1)) * 10 ^ (Len(mystr) - i)
        Next
        toNum1 = mynum
        Exit Function
    Case 1 '万三千....
        toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + 10 ^ (myPos2 - 11)
    Case 2
        Dim temp As String
        temp = Mid(mystr, 1, 1)
        If InStr(1, comString, temp, vbTextCompare) > 19 Then '代表第一位为数字第二位为位符如6万
           toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + Val(temp) * 10 ^ (myPos2 - 11)
        Else '如十万、百万...万万
           toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + 10 ^ (InStr(1, comString, temp, vbTextCompare) - 11 + myPos2 - 11)
        End If
    Case Else
      toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + toNum1(Left(mystr, falg - 1)) * 10 ^ (myPos2 - 11)
End Select

End Function

wqfzqgk

支持原创，学习

sunny_8848

留存备用，多谢分享

时光鸟

wzsy2_mrf 发表于 2014-4-26 19:50
楼主的程序我实在看不懂。测试的时候也出现一些问题，如："万五百十万"，这种数会出现错误。
我自己写了一 ...

"万五百十万"   有这种表达？

袁毅

二亿零七百二十万六千     不行

wzsy2_mrf

袁毅 发表于 2014-7-28 16:20
二亿零七百二十万六千     不行

我早知中间有零的时候会有问题，现在把解决办法一并公布了吧：

wzsy2_mrf

先将数据用下面代码进行标准化处理：

1. Private Function toNumBZH(mystr As String) As String    '此函数将输入的中文数字（允许大写、小写、数字、西文空格混编，如有其它字符出现则输出为空串)
   
2.     Dim i%, k%, k1%, myPos1%
   
3.     Dim str1$, comString$
   
4.     comString = "一壹二贰三叁四肆五伍六陆七柒八捌九玖零〇十拾百佰千仟万萬亿億兆0123456789"
   
5.     mystr = Replace(mystr, " ", "")
   
6.     mystr = Replace(mystr, "貳", "2")
   
7.     mystr = Replace(mystr, "陸", "6")
   
8.     mystr = Replace(mystr, "两", "2")
   
9.     For i = 1 To Len(mystr)
   
10.         str1 = Mid(mystr, i, 1)
    
11.         myPos1 = InStr(1, comString, str1, vbBinaryCompare)
    
12.         If myPos1 = 0 Then Exit Function
    
13.         Select Case myPos1
    
14.         Case 1 To 18
    
15.             mystr = Replace(mystr, str1, Trim(Str(Int((myPos1 + 1) / 2))))
    
16.         Case 19, 20
    
17.             mystr = Replace(mystr, str1, "0")
    
18.         Case 22, 24, 26, 28, 30
    
19.             mystr = Replace(mystr, str1, Mid(comString, myPos1 - 1, 1))
    
20.         End Select
    
21.     Next
    
22.     For i = 1 To Len(mystr)
    
23.         str1 = Mid(mystr, i, 1)
    
24.         myPos1 = InStr(1, comString, str1, vbBinaryCompare)
    
25.         If myPos1 >= 21 And myPos1 <= 31 Then k1 = i
    
26.         If str1 = "0" Then
    
27.             k = InStr(1, comString, Mid(mystr, i + 1, 1), vbBinaryCompare)
    
28.             If k >= 21 And k <= 31 And Val(Mid(mystr, k1 + 1, i - k1)) = 0 Then mystr = Left$(mystr, i - 1) & "1" & Right$(mystr, Len(mystr) - i)
    
29.         End If
    
30.     Next
    
31.     toNumBZH = mystr
    
32. End Function
    
33. 
    

复制代码

wzsy2_mrf

再调用下面的转化函数，那么无论什么整数都可以处理：

1. Private Function toNum1(mystr As String) As Double  'mystr 数据已经经过toNumBZH函数处理
   
2.     Dim i As Integer, myPos1 As Integer, myPos2%, falg%    'falg标志最高位在字串中出现位置，myPos2 表示最高位次数
   
3.     Dim str1 As String
   
4.     Dim comString As String
   
5.     comString = "十百千万┩兆╊亿0123456789"    '加入┩╊为处理方便，如在有可能出现的场合可先清除
   
6.     If mystr = "" Then
   
7.         toNum1 = 0
   
8.         Exit Function
   
9.     End If
   
10.     myPos2 = 0
    
11.     falg = 0
    
12.     For i = 1 To Len(mystr)
    
13.         str1 = Mid(mystr, i, 1)
    
14.         myPos1 = InStr(1, comString, str1, vbBinaryCompare)
    
15.         Select Case myPos1
    
16.         Case 1 To 8
    
17.             If myPos1 >= myPos2 Then
    
18.                 falg = i
    
19.                 myPos2 = myPos1
    
20.             End If
    
21.         End Select
    
22.     Next
    
23.     Select Case falg
    
24.     Case 0    '代表字串为纯数字
    
25.         Dim mynum As Long
    
26.         For i = Len(mystr) To 1 Step -1
    
27.             mynum = mynum + Val(Mid(mystr, i, 1)) * 10 ^ (Len(mystr) - i)
    
28.         Next
    
29.         toNum1 = mynum
    
30.         Exit Function
    
31.     Case 1    '万三千....
    
32.         toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + 10 ^ (myPos2)
    
33.     Case 2
    
34.         Dim temp As String
    
35.         temp = Mid(mystr, 1, 1)
    
36.         If InStr(1, comString, temp, vbBinaryCompare) > 8 Then    '代表第一位为数字第二位为位符如6万
    
37.             toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + Val(temp) * 10 ^ (myPos2)
    
38.         Else    '如十万、百万...万万
    
39.             toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + 10 ^ (InStr(1, comString, temp, vbBinaryCompare) + myPos2)
    
40.         End If
    
41.     Case Else
    
42.         toNum1 = toNum1(Right(mystr, Len(mystr) - falg)) + toNum1(Left(mystr, falg - 1)) * 10 ^ (myPos2)
    
43.     End Select
    
44. End Function
    

复制代码

wzsy2_mrf

你再测试一下是否正确：

1. Sub wsx()
   
2. Dim str1$, myval&
   
3. str1 = "二亿零七百二十万六千"
   
4. myhval = toNum1(toNumBZH(str1))
   
5. End Sub
   

复制代码