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

时光鸟

    大家因为财务工作等需要，平时用得最频繁的就是阿拉伯数字与中文大写之间的转化，现在网络上都有比较简捷高效的代码，甚至有高人用四行代码就解决了阿拉伯数字转中文大写的问题。
    从规律的角度来看，阿拉伯数字转中文小写也好，转中文大写也罢，我认为都相对比较容易，但是中文大写、小写转阿拉伯数字相对就要麻烦一些，尤其是中文小写，规律性较差，随意表达性大，转阿拉伯数字相以就要麻烦一点，再加上可能平时大家用得不多的原因，中文小写转阿拉伯数字的代码并不多。前一阵本人正好要用，找了一圈也没找到现成的相对完美一点的代码，于是想着自己着手来写一个，也就有了以下的这个函数，虽然代码看上去长了一点（没什么高深的东西，都是字符的简单处理，效率不是问题），但自认为相对来说还是比较完美的，也有一定的纠错转化能力。在对一些BUG进行纠正后，现公布出来，有需要的可以拿去用。转化效果看图片：

1. Private Function toNum(myStr)
   
2. '==========================================================
   
3. '中文小写转阿拉伯数字函数
   
4. 'Writen by 时光鸟
   
5. '2012-12-24 于 武汉
   
6. 'ver 1.9 beta (update 2013-1-12)
   
7. '*改进极个别情况最右侧数量级的右侧为非转化文本时的转化Bug
   
8. 'ver 1.8 beta (update 2012-12-30)
   
9. '*改进少数情况下把"二"习惯用成"两"的时候的转化问题
   
10. '*改进极个别情况下"〇"或"零"后直接跟数量级时的转化问题
    
11. '*对小部分中文小写数字的不规范表达增加纠错转化功能
    
12. '*增加对中文小写乘法口诀转化的功能支持
    
13. 'ver 1.7 beta (update 2012-12-29)
    
14. '*改进个别情况下需要在中文小写中同时使用〇和零时的转化问题
    
15. '*优化代码结构，提升效率
    
16. 'ver 1.6 beta (updat'e 2012-12-28)
    
17. '*解决了首位只有数量级时这种简化表达方式转化不正确的Bug
    
18. 'ver 1.5 beta (update 2012-12-27)
    
19. '*解决了〇右侧有多个数量级时某种情况替换数量不正确的Bug
    
20. 'ver 1.4 beta (update 2012-12-27)
    
21. '*解决了〇右侧有多个数量级时替换数量不正确的Bug
    
22. 'ver 1.3 beta (update 2012-12-26)
    
23. '*解决了连续有多个数量级时转化不正确的Bug
    
24. 'ver 1.2 beta (update 2012-12-26)
    
25. '*解决了中文小写中某种情况下使用汉字“零”时转化不正确的Bug
    
26. 'ver 1.1 beta (update 2012-12-25)
    
27. '*解决了中文小写中含有〇的情况下时转化不正确的Bug
    
28. 'ver 1.0 beta (update 2012-12-24)
    
29. '*中文小写转阿拉伯数字正常表达方式转化函数
    
30. '==========================================================
    
31. 
    
32. Dim strG$, strL$, strN$, strZ$, findZ$, addZ$
    
33. Dim i%, m%, n%, k%, Lv%, Rv%, Lx%, Rx%, R1%, R2%, Ly%, Ry%, Tx%
    
34. strG = "十百千万亿"
    
35. strL = "一二三四五六七八九"
    
36. strN = "123456789"
    
37. strZ = "〇零"
    
38. If myStr = "" Then Exit Function
    
39. While (InStr(myStr, Left(strZ, 1)) + InStr(myStr, Right(strZ, 1)) > 0)
    
40.     Lv = InStr(myStr, Left(strZ, 1))
    
41.     Rv = InStr(myStr, Right(strZ, 1))
    
42.     If Lv > 0 Then If Rv = 0 Or Rv > Lv Then findZ = Left(strZ, 1)
    
43.     If Rv > 0 Then If Lv = 0 Or Lv > Rv Then findZ = Right(strZ, 1)
    
44.     m = InStr(myStr, findZ)
    
45.     If m < Len(myStr) And InStr(strG, Mid(myStr, m + 1, 1)) Then
    
46.        myStr = Left(myStr, m) & "一" & Mid(myStr, m + 1)
    
47.     End If
    
48.     If Mid(myStr, m - 1, 1) <> "" Then Lx = InStr(strG, Mid(myStr, m - 1, 1)) Else Lx = 0
    
49.     If Mid(myStr, m + 2, 1) <> "" Then R1 = InStr(strG, Mid(myStr, m + 2, 1)) Else R1 = 0
    
50.     If Mid(myStr, m + 3, 1) <> "" Then R2 = InStr(strG, Mid(myStr, m + 3, 1)) Else R2 = 0
    
51.     If R2 = 5 Then Rx = R1 + R2 + 3 Else Rx = R1 + R2
    
52.     If Lx > 0 And Lx < R1 Then Rx = 0
    
53.     If Lx > R1 And Lx < R2 Then Rx = R1
    
54.     If Lx = 5 Then Lx = Lx + 3
    
55.     If Lx = 0 And Rx = 0 Then Lx = 2
    
56.     myStr = Replace(myStr, findZ, Mid(10 ^ (Lx - Rx - 1), 2), 1, 1)
    
57. Wend
    
58. Do
    
59.   If Len(myStr) < 2 Then Exit Do
    
60.   If Mid(myStr, n + 1, 1) <> "" Then Ly = InStr(strG, Mid(myStr, n + 1, 1)) Else Ly = 0
    
61.   If Mid(myStr, n + 2, 1) <> "" Then Ry = InStr(strG, Mid(myStr, n + 2, 1)) Else Ry = 0
    
62.   If Ly > 0 And Ry > 0 Then
    
63.      If Ly = 5 Then addZ = Mid(10 ^ (Ly + 3), 2) Else addZ = Mid(10 ^ Ly, 2)
    
64.      myStr = Left(myStr, n + 1) & addZ & Mid(myStr, n + 2)
    
65.      n = n + Len(addZ)
    
66.   Else
    
67.      n = n + 1
    
68.   End If
    
69. Loop Until (n = Len(myStr) - 1)
    
70. If Len(myStr) > 3 And InStr(strL, Left(myStr, 1)) * InStr(strL, Mid(myStr, 2, 1)) Then
    
71.    If Len(myStr) = 4 And Mid(myStr, 3, 1) = "得" Then myStr = Left(myStr, 1) & "×" & Replace(Mid(myStr, 2), "得", "=")
    
72.    If Len(myStr) < 6 And InStr(strL, Mid(myStr, 3, 1)) > 0 And InStr(strG, Mid(myStr, 4, 1)) > 0 Then
    
73.       myStr = Left(myStr, 1) & "×" & Mid(myStr, 2, 1) & "=" & Mid(myStr, 3)
    
74.    End If
    
75. End If
    
76. If InStr(myStr, "两") > 0 Then myStr = Replace(myStr, "两", "二")
    
77. If InStr(strG, Left(myStr, 1)) > 0 Then myStr = "一" & myStr
    
78. If Len(myStr) > 1 Then
    
79.    For i = Len(myStr) - 1 To 1 Step -1
    
80.       k = InStr(strG, Right(myStr, 1))
    
81.       If k = 5 Then myStr = myStr & Mid(10 ^ (k + 3), 2) Else If k > 0 Then myStr = myStr & Mid(10 ^ k, 2)
    
82.       If k = 0 Then
    
83.          Tx = InStr(strG, Mid(myStr, i, 1))
    
84.          If Tx > 0 And InStr(strL, Mid(myStr, i + 1, 1)) = 0 And Mid(myStr, i + 1, 1) <> "0" Then
    
85.             If Tx = 5 Then addZ = Mid(10 ^ (Tx + 3), 2) Else addZ = Mid(10 ^ Tx, 2)
    
86.             myStr = Left(myStr, i) & addZ & Mid(myStr, i + 1)
    
87.          End If
    
88.      End If
    
89.    Next i
    
90. End If
    
91. For i = 1 To Len(strL)
    
92.    If i <= Len(strG) And InStr(myStr, Mid(strG, i, 1)) Then myStr = Replace(myStr, Mid(strG, i, 1), "")
    
93.    If InStr(myStr, Mid(strL, i, 1)) > 0 Then myStr = Replace(myStr, Mid(strL, i, 1), Mid(strN, i, 1))
    
94. Next i
    
95. toNum = myStr
    
96. End Function

复制代码

补充内容 (2013-6-17 11:19):
修正升级后的Ver2.0 版就移步 6 楼，感谢excelhome论坛"星语心愿"朋友的反馈意见！

aman1516

终于找到了! 太好了，不过仍得加一句：On Error Resume Next'才能通过。容错方面可能还需大量各类型数据测试才更完善。
这么好的函数怎么没人顶呢。支持原创！

Laofofo

顶起，支持原创。。。

时光鸟

aman1516 发表于 2013-6-14 10:50
终于找到了! 太好了，不过仍得加一句：On Error Resume Next'才能通过。容错方面可能还需大量各类型数据测试 ...

这个使用面是比较窄，我也是在网上找了好久没找到好用的，才想着要自己写一个用

星语心愿

岔河十七组，草坪二十一组等就不对了。还有，可以写成代码吗？不要写成自定义函数。

时光鸟

星语心愿 发表于 2013-6-17 01:30
岔河十七组，草坪二十一组等就不对了。还有，可以写成代码吗？不要写成自定义函数。

已确认问题的存在，现已修正！（原来没打算支持中文小写数字与普通中文混杂这种情况的，呵呵）
自定义函数代码如下，请测试！
自定义函数用起来是最方便，如果想用做过程，写个sub调用就行了，sub调用方式请下载附件测试！如有问题请及时回复，感谢excelhome论坛"星语心愿"朋友的反馈！

1. Private Function toNum(myStr)
   
2. '==========================================================
   
3. '中文小写转阿拉伯数字函数
   
4. 'Writen by 时光鸟
   
5. '2012-12-24 于 武汉
   
6. 
   
7. 'ver 2.0 beta (update 2013-6-17)
   
8. '*改进数量级左侧为非转化文本时的转化Bug(感谢excelhome论坛"星语心愿"朋友的反馈)
   
9. 'ver 1.9 beta (update 2013-1-12)
   
10. '*改进极个别情况最右侧数量级的右侧为非转化文本时的转化Bug
    
11. 'ver 1.8 beta (update 2012-12-30)
    
12. '*改进少数情况下把"二"习惯用成"两"的时候的转化问题
    
13. '*改进极个别情况下"〇"或"零"后直接跟数量级时的转化问题
    
14. '*对小部分中文小写数字的不规范表达增加纠错转化功能
    
15. '*增加对中文小写乘法口诀转化的功能支持
    
16. 'ver 1.7 beta (update 2012-12-29)
    
17. '*改进个别情况下需要在中文小写中同时使用〇和零时的转化问题
    
18. '*优化代码结构，提升效率
    
19. 'ver 1.6 beta (updat'e 2012-12-28)
    
20. '*解决了首位只有数量级时这种简化表达方式转化不正确的Bug
    
21. 'ver 1.5 beta (update 2012-12-27)
    
22. '*解决了〇右侧有多个数量级时某种情况替换数量不正确的Bug
    
23. 'ver 1.4 beta (update 2012-12-27)
    
24. '*解决了〇右侧有多个数量级时替换数量不正确的Bug
    
25. 'ver 1.3 beta (update 2012-12-26)
    
26. '*解决了连续有多个数量级时转化不正确的Bug
    
27. 'ver 1.2 beta (update 2012-12-26)
    
28. '*解决了中文小写中某种情况下使用汉字“零”时转化不正确的Bug
    
29. 'ver 1.1 beta (update 2012-12-25)
    
30. '*解决了中文小写中含有〇的情况下时转化不正确的Bug
    
31. 'ver 1.0 beta (update 2012-12-24)
    
32. '*中文小写转阿拉伯数字正常表达方式转化函数发布
    
33. '==========================================================
    
34. 
    
35. Dim strG$, strL$, strN$, strZ$, findZ$, addZ$
    
36. Dim i%, m%, n%, k%, Lv%, Rv%, Lx%, Rx%, R1%, R2%, Ly%, Ry%, Tx%, flagP%
    
37. strG = "十百千万亿"
    
38. strL = "一二三四五六七八九"
    
39. strN = "123456789"
    
40. strZ = "〇零"
    
41. If myStr = "" Then Exit Function
    
42. While (InStr(myStr, Left(strZ, 1)) + InStr(myStr, Right(strZ, 1)) > 0)
    
43.     Lv = InStr(myStr, Left(strZ, 1))
    
44.     Rv = InStr(myStr, Right(strZ, 1))
    
45.     If Lv > 0 Then If Rv = 0 Or Rv > Lv Then findZ = Left(strZ, 1)
    
46.     If Rv > 0 Then If Lv = 0 Or Lv > Rv Then findZ = Right(strZ, 1)
    
47.     m = InStr(myStr, findZ)
    
48.     If m < Len(myStr) And InStr(strG, Mid(myStr, m + 1, 1)) Then
    
49.        myStr = Left(myStr, m) & "一" & Mid(myStr, m + 1)
    
50.     End If
    
51.     If Mid(myStr, m - 1, 1) <> "" Then Lx = InStr(strG, Mid(myStr, m - 1, 1)) Else Lx = 0
    
52.     If Mid(myStr, m + 2, 1) <> "" Then R1 = InStr(strG, Mid(myStr, m + 2, 1)) Else R1 = 0
    
53.     If Mid(myStr, m + 3, 1) <> "" Then R2 = InStr(strG, Mid(myStr, m + 3, 1)) Else R2 = 0
    
54.     If R2 = 5 Then Rx = R1 + R2 + 3 Else Rx = R1 + R2
    
55.     If Lx > 0 And Lx < R1 Then Rx = 0
    
56.     If Lx > R1 And Lx < R2 Then Rx = R1
    
57.     If Lx = 5 Then Lx = Lx + 3
    
58.     If Lx = 0 And Rx = 0 Then Lx = 2
    
59.     myStr = Replace(myStr, findZ, Mid(10 ^ (Lx - Rx - 1), 2), 1, 1)
    
60. Wend
    
61. Do
    
62.   If Len(myStr) < 2 Then Exit Do
    
63.   If Mid(myStr, n + 1, 1) <> "" Then Ly = InStr(strG, Mid(myStr, n + 1, 1)) Else Ly = 0
    
64.   If Mid(myStr, n + 2, 1) <> "" Then Ry = InStr(strG, Mid(myStr, n + 2, 1)) Else Ry = 0
    
65.   If Ly > 0 And Ry > 0 Then
    
66.      If Ly = 5 Then addZ = Mid(10 ^ (Ly + 3), 2) Else addZ = Mid(10 ^ Ly, 2)
    
67.      myStr = Left(myStr, n + 1) & addZ & Mid(myStr, n + 2)
    
68.      n = n + Len(addZ)
    
69.   Else
    
70.      n = n + 1
    
71.   End If
    
72. Loop Until (n = Len(myStr) - 1)
    
73. If Len(myStr) > 3 And InStr(strL, Left(myStr, 1)) * InStr(strL, Mid(myStr, 2, 1)) Then
    
74.    If Len(myStr) = 4 And Mid(myStr, 3, 1) = "得" Then myStr = Left(myStr, 1) & "×" & Replace(Mid(myStr, 2), "得", "=")
    
75.    If Len(myStr) < 6 And InStr(strL, Mid(myStr, 3, 1)) > 0 And InStr(strG, Mid(myStr, 4, 1)) > 0 Then
    
76.       myStr = Left(myStr, 1) & "×" & Mid(myStr, 2, 1) & "=" & Mid(myStr, 3)
    
77.    End If
    
78. End If
    
79. If InStr(myStr, "两") > 0 Then myStr = Replace(myStr, "两", "二")
    
80. 
    
81. If InStr(strG, Left(myStr, 1)) > 0 Then myStr = "一" & myStr
    
82. While (flagP <= Len(myStr) - 2)
    
83.   flagP = flagP + 1
    
84.   If InStr(strG, Mid(myStr, flagP + 1, 1)) > 0 And InStr(strG & strL & strZ & strN & "1234567890", Mid(myStr, flagP, 1)) = 0 Then
    
85.      myStr = Left(myStr, flagP) & "一" & Mid(myStr, flagP + 1)
    
86.   End If
    
87. Wend
    
88. 
    
89. If Len(myStr) > 1 Then
    
90.    For i = Len(myStr) - 1 To 1 Step -1
    
91.       k = InStr(strG, Right(myStr, 1))
    
92.       If k = 5 Then myStr = myStr & Mid(10 ^ (k + 3), 2) Else If k > 0 Then myStr = myStr & Mid(10 ^ k, 2)
    
93.       If k = 0 Then
    
94.          Tx = InStr(strG, Mid(myStr, i, 1))
    
95.          If Tx > 0 And InStr(strL, Mid(myStr, i + 1, 1)) = 0 And Mid(myStr, i + 1, 1) <> "0" Then
    
96.             If Tx = 5 Then addZ = Mid(10 ^ (Tx + 3), 2) Else addZ = Mid(10 ^ Tx, 2)
    
97.             myStr = Left(myStr, i) & addZ & Mid(myStr, i + 1)
    
98.          End If
    
99.      End If
    
100.    Next i
     
101. End If
     
102. For i = 1 To Len(strL)
     
103.    If i <= Len(strG) And InStr(myStr, Mid(strG, i, 1)) Then myStr = Replace(myStr, Mid(strG, i, 1), "")
     
104.    If InStr(myStr, Mid(strL, i, 1)) > 0 Then myStr = Replace(myStr, Mid(strL, i, 1), Mid(strN, i, 1))
     
105. Next i
     
106. toNum = myStr
     
107. End Function

复制代码

星语心愿

改得很及时啊，谢谢了。在试呢，如果有问题再向您请教了。

aman1516

不断完善了，“○”这里出错了，没转换过来：
桃六百○六
二千○一
二千○一十
二千○一十三

时光鸟

aman1516 发表于 2013-6-17 16:21
不断完善了，“○”这里出错了，没转换过来：
桃六百○六
二千○一

呵呵，你用这个”〇“ 试试，你的用法不规范，正规的用法是数字键盘中的专用”〇“ 符号（见下图），而不是word,excel中的特殊字符圈圈”○“，把两放在一起一比较就出来了”〇○“，呵呵！

aman1516

Good!  是数字中的“○”，可能输入法版本不同，或半角全角的问题。不管怎样，用替换或复制方法，只要数据中的“○”与代码中的“○”一致就OK。太强了！