汉字转换为阿拉伯数字

于箱长

yibao2 发表于 2022-3-22 16:53
将“零”替换为”○“就可以了。
=LOOKUP(,0/(SUBSTITUTE(TEXT(ROW($1:$10000),"[dbnum1]"),"一十","十" ...

九千零五，转换成阿拉拍数字应该是9005，一个零换两个00，九万零五（90005）是一个零换000，我没整对

yibao2

于箱长 发表于 2022-3-22 17:00
九千零五，转换成阿拉拍数字应该是9005，一个零换两个00，九万零五（90005）是一个零换000，我没整 ...

9005，[dbnum1]写作：九千○五
90005，[dbnum1]写作：九万○五
这个格式只有零不同

yibao2

于箱长 发表于 2022-3-22 17:00
九千零五，转换成阿拉拍数字应该是9005，一个零换两个00，九万零五（90005）是一个零换000，我没整 ...

如果数字大点，函数运算量大，电脑吃力。还是你的VB好。可惜我不懂

于箱长

我写的还有不少地方需要完善，不想动脑了，找了一个比较完美的，只对A列和B列稍做了调整，注明了原作者

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

复制代码

向往的歌

满坛皆为吾师 发表于 2022-3-22 14:01
B1下拉，仅供参考

亲测出错

向往的歌

于箱长 发表于 2022-3-22 20:01
我写的还有不少地方需要完善，不想动脑了，找了一个比较完美的，只对A列和B列稍做了调整，注明了原作者

...

亲，突发奇想——想反过来操作，能不能把阿拉伯数字转换成汉字？

于箱长

向往的歌 发表于 2022-3-23 09:20
亲，突发奇想——想反过来操作，能不能把阿拉伯数字转换成汉字？

那个可比这个简单多了

于箱长

1. Function DX(m)
   
2.     DX = Replace(Application.Text(Round(m + 0.00000001, 2), "[dbnum2]"), ".", "元")
   
3.     DX = IIf(Left(Right(DX, 3), 1) = "元", Left(DX, Len(DX) - 1) & "角" & Right(DX, 1) & "分", IIf(Left(Right(DX, 2), 1) = "元", DX & "角整", IIf(DX = "零", "", DX & "元整")))
   
4.     DX = Replace(Replace(Replace(Replace(DX, "零元零角", ""), "零元", ""), "零角", "零"), "-", "负")
   
5. End Function

复制代码

推荐大家一个我自己常用的阿拉伯数字转中文金额的自定义代码，很遗憾，我不知道这个代码是哪位大神的作品

向往的歌

于箱长 发表于 2022-3-23 09:40
推荐大家一个我自己常用的阿拉伯数字转中文金额的自定义代码，很遗憾，我不知道这个代码是哪位大神的作品 ...

亲，似乎运行不了请教：如何才能运行？

于箱长

向往的歌 发表于 2022-3-23 10:11
亲，似乎运行不了请教：如何才能运行？

自定义函数是这么用的